[MLton-commit] r4468
Matthew Fluet
MLton@mlton.org
Sat, 6 May 2006 11:44:55 -0700
Merge and drop .refactor
----------------------------------------------------------------------
U mlton/branches/on-20050822-x86_64-branch/Makefile
U mlton/branches/on-20050822-x86_64-branch/basis-library/Makefile
U mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/array-slice.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/array.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/array.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/array2.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/mono-array.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/mono.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/sequence.fun
U mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/sequence.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/slice.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/vector-slice.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/vector.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/vector.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/build/
A mlton/branches/on-20050822-x86_64-branch/basis-library/config/bind/
U mlton/branches/on-20050822-x86_64-branch/basis-library/config/c/amd64-linux/c-types.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/config/c/errno.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/config/c/position.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/config/c/sys-word.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/config/c/test/
U mlton/branches/on-20050822-x86_64-branch/basis-library/config/c/x86-linux/c-types.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/config/choose.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/config/default/
A mlton/branches/on-20050822-x86_64-branch/basis-library/config/header/
A mlton/branches/on-20050822-x86_64-branch/basis-library/config/objptr/
A mlton/branches/on-20050822-x86_64-branch/basis-library/config/seqindex/
U mlton/branches/on-20050822-x86_64-branch/basis-library/general/general.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/general/option.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/integer/embed-int.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/integer/embed-word.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int-global.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int-inf.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int-inf.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int-inf0.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int-inf1.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int0.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int1.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/integer/integer.sig
A mlton/branches/on-20050822-x86_64-branch/basis-library/integer/pack-word.sml
D mlton/branches/on-20050822-x86_64-branch/basis-library/integer/pack-word32.sml
D mlton/branches/on-20050822-x86_64-branch/basis-library/integer/patch.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/integer/word-global.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/integer/word.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/integer/word.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/integer/word0.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/integer/word1.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/io/bin-io.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/io/imperative-io.fun
U mlton/branches/on-20050822-x86_64-branch/basis-library/io/io.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/io/prim-io.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/io/text-io.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-2002/top-level/basis.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-extra/basis-extra.mlb
U mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-extra/top-level/basis.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-extra/top-level/basis.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/list/list.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/maps/
D mlton/branches/on-20050822-x86_64-branch/basis-library/misc/
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/call-stack.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/cont.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/exit.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/exn.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/ffi.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/ffi.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/finalizable.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/gc.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/int-inf.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/itimer.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/mlton.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/pointer.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/pointer.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/proc-env.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/process.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/profile.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/random.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/rlimit.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/rlimit.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/rusage.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/signal.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/socket.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/socket.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/syslog.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/thread.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/vector.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/word.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/world.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/net/generic-sock.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/net/inet-sock.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/net/net-host-db.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/net/net-host-db.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/net/net-prot-db.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/net/net-serv-db.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/net/net.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/net/net.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/net/socket.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/net/socket.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/net/unix-sock.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/posix/error.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/posix/error.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/posix/file-sys.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/posix/file-sys.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/posix/flags.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/posix/flags.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/posix/io.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/posix/posix.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/posix/proc-env.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/posix/process.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/posix/stub-mingw.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/posix/sys-db.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/posix/tty.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/basis-ffi.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/check-pack-real.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/check-pack-word.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/check-real.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-basis.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-char.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-int-inf.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-int.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-mlton.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-nullstring.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-pack-real.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-pack-word.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-real.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-seq.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-string.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-word.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim1.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim2.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/primitive.mlb
D mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/primitive.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/real/IEEE-real.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/real/IEEE-real.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/real/pack-real.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/real/real-global.sml
D mlton/branches/on-20050822-x86_64-branch/basis-library/real/real.fun
U mlton/branches/on-20050822-x86_64-branch/basis-library/real/real.sig
A mlton/branches/on-20050822-x86_64-branch/basis-library/real/real.sml
D mlton/branches/on-20050822-x86_64-branch/basis-library/real/real32.sml
D mlton/branches/on-20050822-x86_64-branch/basis-library/real/real64.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/sml-nj/unsafe.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/system/command-line.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/system/date.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/system/file-sys.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/system/io.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/system/pre-os.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/system/process.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/system/process.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/system/time.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/text/byte.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/text/char-global.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/text/char.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/text/char0.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/text/nullstring.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/text/string-cvt.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/text/string-global.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/text/string.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/text/string0.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/text/substring-global.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/text/substring.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/top-level/infixes-unsafe.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library/util/
D mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/
U mlton/branches/on-20050822-x86_64-branch/mlton/control/control-flags.sml
U mlton/branches/on-20050822-x86_64-branch/mlton/front-end/mlb-front-end.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/main/main.fun
U mlton/branches/on-20050822-x86_64-branch/runtime/Makefile
----------------------------------------------------------------------
Modified: mlton/branches/on-20050822-x86_64-branch/Makefile
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/Makefile 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/Makefile 2006-05-06 18:44:35 UTC (rev 4468)
@@ -69,7 +69,7 @@
basis-no-check:
mkdir -p $(LIB)/sml
rm -rf $(LIB)/sml/basis
- $(CP) $(SRC)/basis-library.refactor/. $(LIB)/sml/basis
+ $(CP) $(SRC)/basis-library/. $(LIB)/sml/basis
find $(LIB)/sml/basis -type d -name .svn | xargs rm -rf
find $(LIB)/sml/basis -type f -name .ignore | xargs rm -rf
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/Makefile
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/Makefile 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/Makefile 2006-05-06 18:44:35 UTC (rev 4468)
@@ -6,9 +6,58 @@
# See the file MLton-LICENSE for details.
##
+SRC = $(shell cd .. && pwd)
+BUILD = $(SRC)/build
+BIN = $(BUILD)/bin
+MLTON = mlton
+PATH = $(BIN):$(shell echo $$PATH)
+
all:
.PHONY: clean
clean:
find . -type f | egrep '.(old|ast|core-ml)$$' | xargs rm -f
../bin/clean
+
+
+OBJPTR_MAPS = objptr-rep32.map objptr-rep64.map
+HEADER_MAPS = header-word32.map header-word64.map
+SEQINDEX_MAPS = seqindex-int32.map seqindex-int64.map
+TARGET_ARCH = x86 amd64
+TARGET_OS = linux
+DEFAULT_CHAR = char8
+DEFAULT_INT = int32 int64 intinf
+DEFAULT_REAL = real32 real64
+DEFAULT_WORD = word32 word64
+
+.PHONY: type-check-def
+type-check-def:
+ $(MLTON) -disable-ann deadCode -stop tc -show-types true \
+ libs/all.mlb; \
+
+.PHONY: type-check-all
+type-check-all:
+ for objptrrep in $(OBJPTR_MAPS); do \
+ for header in $(HEADER_MAPS); do \
+ for seqindex in $(SEQINDEX_MAPS); do \
+ for targetarch in $(TARGET_ARCH); do \
+ for targetos in $(TARGET_OS); do \
+ for defchar in $(DEFAULT_CHAR); do \
+ for defint in $(DEFAULT_INT); do \
+ for defreal in $(DEFAULT_REAL); do \
+ for defword in $(DEFAULT_WORD); do \
+ if [ ! -r config/c/$$targetarch-$$targetos/c-types.sml ]; then \
+ break; \
+ fi; \
+ echo "Type checking: $$objptrrep $$header $$seqindex $$targetarch $$targetos $$defchar $$defint $$defreal $$defword"; \
+ $(MLTON) -disable-ann deadCode -stop tc -show-types true \
+ -mlb-path-map "maps/$$objptrrep" \
+ -mlb-path-map "maps/$$header" \
+ -mlb-path-map "maps/$$seqindex" \
+ -mlb-path-map "maps/c-types.$$targetarch-$$targetos.map" \
+ -default-type "$$defchar" \
+ -default-type "$$defint" \
+ -default-type "$$defreal" \
+ -default-type "$$defword" \
+ libs/all.mlb; \
+ done; done; done; done; done; done; done; done; done
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/array-slice.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/array-slice.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/array-slice.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -1,3 +1,8 @@
+structure Array =
+ struct
+ type 'a array = 'a array
+ end
+
signature ARRAY_SLICE_GLOBAL =
sig
end
@@ -43,8 +48,15 @@
val concat: 'a slice list -> 'a array
val toList: 'a slice -> 'a list
+ val slice': 'a array * SeqIndex.int * SeqIndex.int option -> 'a slice
+ val unsafeSlice': 'a array * SeqIndex.int * SeqIndex.int option -> 'a slice
val unsafeSlice: 'a array * int * int option -> 'a slice
+ val sub': 'a slice * SeqIndex.int -> 'a
+ val unsafeSub': 'a slice * SeqIndex.int -> 'a
val unsafeSub: 'a slice * int -> 'a
+ val unsafeSubslice': 'a slice * SeqIndex.int * SeqIndex.int option -> 'a slice
val unsafeSubslice: 'a slice * int * int option -> 'a slice
+ val update': 'a slice * SeqIndex.int * 'a -> unit
+ val unsafeUpdate': 'a slice * SeqIndex.int * 'a -> unit
val unsafeUpdate: 'a slice * int * 'a -> unit
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/array.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/array.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/array.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -40,11 +40,16 @@
structure ArraySlice: ARRAY_SLICE_EXTRA
+ val arrayUninit': SeqIndex.int -> 'a array
+ val arrayUninit: int -> 'a array
+ val array': SeqIndex.int * 'a -> 'a array
+ val unsafeSub': 'a array * SeqIndex.int -> 'a
+ val unsafeSub: 'a array * int -> 'a
+ val unsafeUpdate': 'a array * SeqIndex.int * 'a -> unit
+ val unsafeUpdate: 'a array * int * 'a -> unit
+
val concat: 'a array list -> 'a array
val duplicate: 'a array -> 'a array
- val rawArray: int -> 'a array
val toList: 'a array -> 'a list
val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a array * 'b
- val unsafeSub: 'a array * int -> 'a
- val unsafeUpdate: 'a array * int * 'a -> unit
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/array.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/array.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/array.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -13,28 +13,43 @@
val fromArray = fn a => a
val isMutable = true
val length = Primitive.Array.length
- val sub = Primitive.Array.sub)
+ val subUnsafe = Primitive.Array.subUnsafe)
open A
- open Primitive.Int
+ val op +? = Int.+?
+ val op + = Int.+
+ val op -? = Int.-?
+ val op - = Int.-
+ val op < = Int.<
+ val op <= = Int.<=
+ val op > = Int.>
+ val op >= = Int.>=
+
+ fun wrap2 f = fn (i, x) => f (SeqIndex.toIntUnsafe i, x)
+
type 'a array = 'a array
type 'a vector = 'a Vector.vector
structure ArraySlice =
struct
open Slice
+ fun update' (arr, i, x) =
+ updateMk' Primitive.Array.updateUnsafe (arr, i, x)
fun update (arr, i, x) =
- update' Primitive.Array.update (arr, i, x)
+ updateMk Primitive.Array.updateUnsafe (arr, i, x)
+ fun unsafeUpdate' (arr, i, x) =
+ unsafeUpdateMk' Primitive.Array.updateUnsafe (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, x))) sl
+ unsafeUpdateMk Primitive.Array.updateUnsafe (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, x))) sl
+ fun modifyi f sl = modifyi' (wrap2 f) 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)))
+ 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
@@ -42,25 +57,23 @@
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)))
+ foldri' (fn (i, _, _) =>
+ unsafeUpdate' (sl, i, unsafeSub' (src, i)))
() sl
end
- else make (length, unsafeSub) arg
+ else make (length, unsafeSub') arg
end
fun copyVec arg =
- make (Vector.VectorSlice.length, Vector.VectorSlice.unsafeSub) arg
+ make (Vector.VectorSlice.length, Vector.VectorSlice.unsafeSub') arg
end
end
- val rawArray = Primitive.Array.array
- val array = new
-
local
fun make f arr = f (ArraySlice.full arr)
in
fun vector arr = make (ArraySlice.vector) arr
+ fun modifyi' f = make (ArraySlice.modifyi' f)
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,
@@ -69,9 +82,15 @@
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
+ val arrayUninit' = newUninit'
+ val arrayUninit = newUninit
+ val array' = new'
+ val array = new
+
+ fun update' (arr, i, x) = updateMk' Primitive.Array.updateUnsafe (arr, i, x)
+ fun update (arr, i, x) = updateMk Primitive.Array.updateUnsafe (arr, i, x)
+ fun unsafeUpdate' (arr, i, x) = unsafeUpdateMk' Primitive.Array.updateUnsafe (arr, i, x)
+ fun unsafeUpdate (arr, i, x) = unsafeUpdateMk Primitive.Array.updateUnsafe (arr, i, x)
end
structure ArraySlice: ARRAY_SLICE_EXTRA = Array.ArraySlice
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/array2.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/array2.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/array2.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -6,86 +6,183 @@
* See the file MLton-LICENSE for details.
*)
-structure Array2: ARRAY2 =
+structure Array2 (* : ARRAY2 *) =
struct
- open Primitive.Int
- (* I am careful to use a type here instead of a datatype so that
- * 'a array will be an equality type irrespective of whether 'a is.
- * This is probably just an NJ-ism, but I don't want to think about it.
- *)
- type 'a array = {rows: int,
- cols: int,
- array: 'a Array.array}
+ val op +? = SeqIndex.+?
+ val op + = SeqIndex.+
+ val op -? = SeqIndex.-?
+ val op - = SeqIndex.-
+ val op *? = SeqIndex.*?
+ val op * = SeqIndex.*
+ val op < = SeqIndex.<
+ val op <= = SeqIndex.<=
+ val op > = SeqIndex.>
+ val op >= = SeqIndex.>=
+ val ltu = SeqIndex.ltu
+ val leu = SeqIndex.leu
+ val gtu = SeqIndex.gtu
+ val geu = SeqIndex.geu
- fun dimensions ({rows, cols, ...}: 'a array) = (rows, cols)
- fun nRows ({rows, ...}: 'a array) = rows
- fun nCols ({cols, ...}: 'a array) = cols
+ type 'a array = {array: 'a Array.array,
+ rows: SeqIndex.int,
+ cols: SeqIndex.int}
+ fun dimensions' ({rows, cols, ...}: 'a array) = (rows, cols)
+ fun dimensions ({rows, cols, ...}: 'a array) =
+ (SeqIndex.toIntUnsafe rows, SeqIndex.toIntUnsafe cols)
+ fun nRows' ({rows, ...}: 'a array) = rows
+ fun nRows ({rows, ...}: 'a array) = SeqIndex.toIntUnsafe rows
+ fun nCols' ({cols, ...}: 'a array) = cols
+ fun nCols ({cols, ...}: 'a array) = SeqIndex.toIntUnsafe cols
+
type 'a region = {base: 'a array,
row: int,
col: int,
nrows: int option,
ncols: int option}
- fun checkSliceMax (start: int, num: int option, max: int): int =
- case num of
- NONE =>
- if Primitive.safe andalso (start < 0 orelse start > max) then
- raise Subscript
- else
- max
- | SOME num =>
- if Primitive.safe
- andalso (start < 0
- orelse num < 0
- orelse start > max -? num) then
- raise Subscript
- else
- start +? num
+ local
+ fun checkSliceMax' (start: int,
+ num: SeqIndex.int option,
+ max: SeqIndex.int): SeqIndex.int * SeqIndex.int =
+ case num of
+ NONE => if Primitive.Controls.safe
+ then let
+ val start =
+ (SeqIndex.fromInt start)
+ handle Overflow => raise Subscript
+ in
+ if gtu (start, max)
+ then raise Subscript
+ else (start, max)
+ end
+ else (SeqIndex.fromIntUnsafe start, max)
+ | SOME num => if Primitive.Controls.safe
+ then let
+ val start =
+ (SeqIndex.fromInt start)
+ handle Overflow => raise Subscript
+ in
+ if (start < 0 orelse num < 0
+ orelse start +? num > max)
+ then raise Subscript
+ else (start, start +? num)
+ end
+ else (SeqIndex.fromIntUnsafe start,
+ SeqIndex.fromIntUnsafe start +? num)
+ fun checkSliceMax (start: int,
+ num: int option,
+ max: SeqIndex.int): SeqIndex.int * SeqIndex.int =
+ if Primitive.Controls.safe
+ then (checkSliceMax' (start, Option.map SeqIndex.fromInt num, max))
+ handle Overflow => raise Subscript
+ else checkSliceMax' (start, Option.map SeqIndex.fromIntUnsafe num, max)
+ in
+ fun checkRegion' {base, row, col, nrows, ncols} =
+ let
+ val (rows, cols) = dimensions' base
+ val (startRow, stopRow) = checkSliceMax' (row, nrows, rows)
+ val (startCol, stopCol) = checkSliceMax' (col, ncols, cols)
+ in
+ {startRow = startRow, stopRow = stopRow,
+ startCol = startCol, stopCol = stopCol}
+ end
+ fun checkRegion {base, row, col, nrows, ncols} =
+ let
+ val (rows, cols) = dimensions' base
+ val (startRow, stopRow) = checkSliceMax (row, nrows, rows)
+ val (startCol, stopCol) = checkSliceMax (col, ncols, cols)
+ in
+ {startRow = startRow, stopRow = stopRow,
+ startCol = startCol, stopCol = stopCol}
+ end
+ end
- fun checkRegion {base, row, col, nrows, ncols} =
- let
- val (rows, cols) = dimensions base
- in
- {stopRow = checkSliceMax (row, nrows, rows),
- stopCol = checkSliceMax (col, ncols, cols)}
- end
-
- fun wholeRegion (a: 'a array): 'a region =
+ fun wholeRegion (a as {rows, cols, ...}: 'a array): 'a region =
{base = a, row = 0, col = 0, nrows = NONE, ncols = NONE}
datatype traversal = RowMajor | ColMajor
local
fun make (rows, cols, doit) =
- if Primitive.safe andalso (rows < 0 orelse cols < 0)
+ if Primitive.Controls.safe
+ andalso (rows < 0 orelse cols < 0)
then raise Size
- else {rows = rows,
- cols = cols,
- array = doit (rows * cols handle Overflow => raise Size)}
+ else {array = doit (rows * cols handle Overflow => raise Size),
+ rows = rows,
+ cols = cols}
in
+ fun arrayUninit' (rows, cols) =
+ make (rows, cols, Array.arrayUninit')
+ fun array' (rows, cols, init) =
+ make (rows, cols, fn size => Array.array' (size, init))
+ end
+ local
+ fun make (rows, cols, doit) =
+ if Primitive.Controls.safe
+ then let
+ val rows =
+ (SeqIndex.fromInt rows)
+ handle Overflow => raise Size
+ val cols =
+ (SeqIndex.fromInt cols)
+ handle Overflow => raise Size
+ in
+ doit (rows, cols)
+ end
+ else doit (SeqIndex.fromIntUnsafe rows,
+ SeqIndex.fromIntUnsafe cols)
+ in
fun arrayUninit (rows, cols) =
- make (rows, cols, Primitive.Array.array)
+ make (rows, cols, fn (rows, cols) => arrayUninit' (rows, cols))
fun array (rows, cols, init) =
- make (rows, cols, fn size => Array.array (size, init))
+ make (rows, cols, fn (rows, cols) => array' (rows, cols, init))
end
fun array0 (): 'a array =
- {rows = 0,
- cols = 0,
- array = Primitive.Array.array 0}
+ {array = Array.arrayUninit' 0,
+ rows = 0,
+ cols = 0}
- fun spot ({rows, cols, ...}: 'a array, r, c) =
- if Primitive.safe andalso (geu (r, rows) orelse geu (c, cols))
+ fun unsafeSpot' (a as {cols, ...}: 'a array, r, c) =
+ r *? cols +? c
+ fun spot' (a as {rows, cols, ...}: 'a array, r, c) =
+ if Primitive.Controls.safe
+ andalso (geu (r, rows) orelse geu (c, cols))
then raise Subscript
- else r *? cols +? c
+ else unsafeSpot' (a, r, c)
- fun sub (a as {array, ...}: 'a array, r, c) =
- Primitive.Array.sub (array, spot (a, r, c))
+ fun unsafeSub' (a as {array, ...}: 'a array, r, c) =
+ Array.unsafeSub' (array, unsafeSpot' (a, r, c))
+ fun sub' (a as {array, ...}: 'a array, r, c) =
+ Array.unsafeSub' (array, spot' (a, r, c))
+ fun unsafeUpdate' (a as {array, ...}: 'a array, r, c, x) =
+ Array.unsafeUpdate' (array, unsafeSpot' (a, r, c), x)
+ fun update' (a as {array, ...}: 'a array, r, c, x) =
+ Array.unsafeUpdate' (array, spot' (a, r, c), x)
- fun update (a as {array, ...}: 'a array, r, c, x) =
- Primitive.Array.update (array, spot (a, r, c), x)
+ local
+ fun make (r, c, doit) =
+ if Primitive.Controls.safe
+ then let
+ val r =
+ (SeqIndex.fromInt r)
+ handle Overflow => raise Subscript
+ val c =
+ (SeqIndex.fromInt c)
+ handle Overflow => raise Subscript
+ in
+ doit (r, c)
+ end
+ else doit (SeqIndex.fromIntUnsafe r,
+ SeqIndex.fromIntUnsafe c)
+ in
+ fun sub (a, r, c) =
+ make (r, c, fn (r, c) => sub' (a, r, c))
+ fun update (a, r, c, x) =
+ make (r, c, fn (r, c) => update' (a, r, c, x))
+ end
fun 'a fromList (rows: 'a list list): 'a array =
case rows of
@@ -93,18 +190,19 @@
| row1 :: _ =>
let
val cols = length row1
- val a as {array, ...} = arrayUninit (length rows, cols)
+ val a as {array, rows = rows', cols = cols', ...} =
+ arrayUninit (length rows, cols)
val _ =
List.foldl
(fn (row: 'a list, i) =>
let
- val max = i +? cols
+ val max = i +? cols'
val i' =
List.foldl (fn (x: 'a, i) =>
(if i >= max
then raise Size
- else (Primitive.Array.update (array, i, x)
- ; i + 1)))
+ else (Array.unsafeUpdate' (array, i, x)
+ ; i +? 1)))
i row
in if i' = max
then i'
@@ -115,37 +213,77 @@
a
end
- fun row ({rows, cols, array}, r) =
- if Primitive.safe andalso geu (r, rows)
+ fun row' ({array, rows, cols}, r) =
+ if Primitive.Controls.safe andalso geu (r, rows)
then raise Subscript
else
- ArraySlice.vector (ArraySlice.slice (array, r *? cols, SOME cols))
-
- fun column (a as {rows, cols, ...}: 'a array, c) =
- if Primitive.safe andalso geu (c, cols)
+ ArraySlice.vector (ArraySlice.slice' (array, r *? cols, SOME cols))
+ fun row (a, r) =
+ if Primitive.Controls.safe
+ then let
+ val r =
+ (SeqIndex.fromInt r)
+ handle Overflow => raise Subscript
+ in
+ row' (a, r)
+ end
+ else row' (a, SeqIndex.fromIntUnsafe r)
+ fun column' (a as {rows, cols, ...}: 'a array, c) =
+ if Primitive.Controls.safe andalso geu (c, cols)
then raise Subscript
else
- Vector.tabulate (rows, fn r => sub(a, r, c))
+ Vector.tabulate' (rows, fn r => unsafeSub' (a, r, c))
+ fun column (a, c) =
+ if Primitive.Controls.safe
+ then let
+ val c =
+ (SeqIndex.fromInt c)
+ handle Overflow => raise Subscript
+ in
+ column' (a, c)
+ end
+ else column' (a, SeqIndex.fromIntUnsafe c)
- fun foldi trv f b (region as {base, row, col, ...}) =
+ fun foldi' trv f b (region as {base, row, col, ...}) =
let
- val {stopRow, stopCol} = checkRegion region
+ val {startRow, stopRow, startCol, stopCol} = checkRegion region
in
case trv of
RowMajor =>
- Util.naturalFoldStartStop
- (row, stopRow, b, fn (r, b) =>
- Util.naturalFoldStartStop
- (col, stopCol, b, fn (c, b) =>
- f (r, c, sub (base, r, c), b)))
+ let
+ fun loopRow (r, b) =
+ if r >= stopRow then b
+ else let
+ fun loopCol (c, b) =
+ if c >= stopCol then b
+ else loopCol (c +? 1, f (r, c, sub' (base, r, c), b))
+ in
+ loopRow (r +? 1, loopCol (startCol, b))
+ end
+ in
+ loopRow (startRow, b)
+ end
| ColMajor =>
- Util.naturalFoldStartStop
- (col, stopCol, b, fn (c, b) =>
- Util.naturalFoldStartStop
- (row, stopRow, b, fn (r, b) =>
- f (r, c, sub (base, r, c), b)))
+ let
+ fun loopCol (c, b) =
+ if c >= stopCol then b
+ else let
+ fun loopRow (r, b) =
+ if r >= stopRow then b
+ else loopRow (r +? 1, f (r, c, sub' (base, r, c), b))
+ in
+ loopCol (c +? 1, loopRow (startRow, b))
+ end
+ in
+ loopCol (startCol, b)
+ end
end
+ fun foldi trv f b a =
+ foldi' trv (fn (r, c, x, b) =>
+ f (SeqIndex.toIntUnsafe r,
+ SeqIndex.toIntUnsafe c,
+ x, b)) b a
fun fold trv f b a =
foldi trv (fn (_, _, x, b) => f (x, b)) b (wholeRegion a)
@@ -160,22 +298,24 @@
fun modify trv f a = modifyi trv (f o #3) (wholeRegion a)
fun tabulate trv (rows, cols, f) =
- let
+ let
val a = arrayUninit (rows, cols)
val () = modifyi trv (fn (r, c, _) => f (r, c)) (wholeRegion a)
- in
+ in
a
end
- fun copy {src = src as {base, row, col, ...}: 'a region,
+ fun copy {src = src as {base, ...}: 'a region,
dst, dst_row, dst_col} =
let
- val {stopRow, stopCol} = checkRegion src
- val nrows = stopRow -? row
- val ncols = stopCol -? col
- val _ = checkRegion {base = dst, row = dst_row, col = dst_col,
- nrows = SOME nrows, ncols = SOME ncols}
- fun for (start, stop, f: int -> unit) =
+ val {startRow, stopRow, startCol, stopCol} = checkRegion src
+ val nrows = stopRow -? startRow
+ val ncols = stopCol -? startCol
+ val {startRow = dst_row, startCol = dst_col, ...} =
+ checkRegion' {base = dst, row = dst_row, col = dst_col,
+ nrows = SOME nrows,
+ ncols = SOME ncols}
+ fun forUp (start, stop, f: SeqIndex.int -> unit) =
let
fun loop i =
if i >= stop
@@ -183,7 +323,7 @@
else (f i; loop (i + 1))
in loop start
end
- fun forDown (start, stop, f: int -> unit) =
+ fun forDown (start, stop, f: SeqIndex.int -> unit) =
let
fun loop i =
if i < start
@@ -191,11 +331,11 @@
else (f i; loop (i - 1))
in loop (stop -? 1)
end
- val forRows = if row <= dst_row then forDown else for
- val forCols = if col <= dst_col then for else forDown
+ val forRows = if startRow <= dst_row then forDown else forUp
+ val forCols = if startCol <= dst_col then forUp else forDown
in forRows (0, nrows, fn r =>
- forCols (0, ncols, fn c =>
- update (dst, dst_row +? r, dst_col +? c,
- sub (base, row +? r, col +? c))))
+ forCols (0, ncols, fn c =>
+ unsafeUpdate' (dst, dst_row +? r, dst_col +? c,
+ unsafeSub' (base, startRow +? r, startCol +? c))))
end
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/mono-array.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/mono-array.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/mono-array.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -39,10 +39,11 @@
and type vector = vector
and type vector_slice = vector_slice
+ val arrayUninit: int -> array
+
val concat: array list -> array
val duplicate: array -> array
val fromPoly: elem Array.array -> array
- val rawArray: int -> array
val toList: array -> elem list
val toPoly: array -> elem Array.array
val unfoldi: int * 'a * (int * 'a -> elem * 'a) -> array * 'a
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/mono.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/mono.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/mono.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -44,7 +44,7 @@
end
local
- structure S = EqMono (type elem = Bool.bool)
+ structure S = EqMono (type elem = Primitive.Bool.bool)
open S
in
structure BoolVector = Vector
@@ -54,24 +54,9 @@
structure BoolArray2 = Array2
end
local
- structure S:>
- EQ_MONO
- where type Array.elem = char
- where type Vector.vector = string
- = EqMono (type elem = char)
+ structure S = EqMono (type elem = Primitive.Int8.int)
open S
in
- structure CharArray = Array
- structure CharArray2 = Array2
- structure CharArraySlice = ArraySlice
- structure CharVector = Vector
- structure CharVectorSlice = VectorSlice
- val _ = CharVector.fromArray: CharArray.array -> CharVector.vector
-end
-local
- structure S = EqMono (type elem = Int8.int)
- open S
-in
structure Int8Vector = Vector
structure Int8VectorSlice = VectorSlice
structure Int8Array = Array
@@ -79,7 +64,7 @@
structure Int8Array2 = Array2
end
local
- structure S = EqMono (type elem = Int16.int)
+ structure S = EqMono (type elem = Primitive.Int16.int)
open S
in
structure Int16Vector = Vector
@@ -89,7 +74,7 @@
structure Int16Array2 = Array2
end
local
- structure S = EqMono (type elem = Int32.int)
+ structure S = EqMono (type elem = Primitive.Int32.int)
open S
in
structure Int32Vector = Vector
@@ -99,7 +84,7 @@
structure Int32Array2 = Array2
end
local
- structure S = EqMono (type elem = Int64.int)
+ structure S = EqMono (type elem = Primitive.Int64.int)
open S
in
structure Int64Vector = Vector
@@ -109,7 +94,7 @@
structure Int64Array2 = Array2
end
local
- structure S = EqMono (type elem = IntInf.int)
+ structure S = EqMono (type elem = Primitive.IntInf.int)
open S
in
structure IntInfVector = Vector
@@ -119,7 +104,7 @@
structure IntInfArray2 = Array2
end
local
- structure S = Mono (type elem = Real32.real)
+ structure S = Mono (type elem = Primitive.Real32.real)
open S
in
structure Real32Vector = Vector
@@ -129,7 +114,7 @@
structure Real32Array2 = Array2
end
local
- structure S = Mono (type elem = Real64.real)
+ structure S = Mono (type elem = Primitive.Real64.real)
open S
in
structure Real64Vector = Vector
@@ -139,10 +124,7 @@
structure Real64Array2 = Array2
end
local
- structure S:>
- EQ_MONO
- where type Array.elem = Word8.word
- = EqMono (type elem = Word8.word)
+ structure S = EqMono (type elem = Primitive.Word8.word)
open S
in
structure Word8Vector = Vector
@@ -152,7 +134,7 @@
structure Word8Array2 = Array2
end
local
- structure S = EqMono (type elem = Word16.word)
+ structure S = EqMono (type elem = Primitive.Word16.word)
open S
in
structure Word16Vector = Vector
@@ -162,7 +144,7 @@
structure Word16Array2 = Array2
end
local
- structure S = EqMono (type elem = Word32.word)
+ structure S = EqMono (type elem = Primitive.Word32.word)
open S
in
structure Word32Vector = Vector
@@ -172,7 +154,7 @@
structure Word32Array2 = Array2
end
local
- structure S = EqMono (type elem = Word64.word)
+ structure S = EqMono (type elem = Primitive.Word64.word)
open S
in
structure Word64Vector = Vector
@@ -182,38 +164,74 @@
structure Word64Array2 = Array2
end
-structure IntVector = Int32Vector
-structure IntVectorSlice = Int32VectorSlice
-structure IntArray = Int32Array
-structure IntArraySlice = Int32ArraySlice
-structure IntArray2 = Int32Array2
-structure LargeIntVector = IntInfVector
-structure LargeIntVectorSlice = IntInfVectorSlice
-structure LargeIntArray = IntInfArray
-structure LargeIntArraySlice = IntInfArraySlice
-structure LargeIntArray2 = IntInfArray2
-
-structure RealVector = Real64Vector
-structure RealVectorSlice = Real64VectorSlice
-structure RealArray = Real64Array
-structure RealArraySlice = Real64ArraySlice
-structure RealArray2 = Real64Array2
-
-structure LargeRealVector = Real64Vector
-structure LargeRealVectorSlice = Real64VectorSlice
-structure LargeRealArray = Real64Array
-structure LargeRealArraySlice = Real64ArraySlice
-structure LargeRealArray2 = Real64Array2
-
-structure WordVector = Word32Vector
-structure WordVectorSlice = Word32VectorSlice
-structure WordArray = Word32Array
-structure WordArraySlice = Word32ArraySlice
-structure WordArray2 = Word32Array2
-
-structure LargeWordVector = Word64Vector
-structure LargeWordVectorSlice = Word64VectorSlice
-structure LargeWordArray = Word64Array
-structure LargeWordArraySlice = Word64ArraySlice
-structure LargeWordArray2 = Word64Array2
+local
+ structure S = EqMono (type elem = Char.char)
+ open S
+in
+ structure CharArray = Array
+ structure CharArray2 = Array2
+ structure CharArraySlice = ArraySlice
+ structure CharVector = Vector
+ structure CharVectorSlice = VectorSlice
+end
+local
+ structure S = EqMono (type elem = Int.int)
+ open S
+in
+ structure IntVector = Vector
+ structure IntVectorSlice = VectorSlice
+ structure IntArray = Array
+ structure IntArraySlice = ArraySlice
+ structure IntArray2 = Array2
+end
+local
+ structure S = EqMono (type elem = LargeInt.int)
+ open S
+in
+ structure LargeIntVector = Vector
+ structure LargeIntVectorSlice = VectorSlice
+ structure LargeIntArray = Array
+ structure LargeIntArraySlice = ArraySlice
+ structure LargeIntArray2 = Array2
+end
+local
+ structure S = Mono (type elem = Real.real)
+ open S
+in
+ structure RealVector = Vector
+ structure RealVectorSlice = VectorSlice
+ structure RealArray = Array
+ structure RealArraySlice = ArraySlice
+ structure RealArray2 = Array2
+end
+local
+ structure S = Mono (type elem = LargeReal.real)
+ open S
+in
+ structure LargeRealVector = Vector
+ structure LargeRealVectorSlice = VectorSlice
+ structure LargeRealArray = Array
+ structure LargeRealArraySlice = ArraySlice
+ structure LargeRealArray2 = Array2
+end
+local
+ structure S = EqMono (type elem = Word.word)
+ open S
+in
+ structure WordVector = Vector
+ structure WordVectorSlice = VectorSlice
+ structure WordArray = Array
+ structure WordArraySlice = ArraySlice
+ structure WordArray2 = Array2
+end
+local
+ structure S = EqMono (type elem = LargeWord.word)
+ open S
+in
+ structure LargeWordVector = Vector
+ structure LargeWordVectorSlice = VectorSlice
+ structure LargeWordArray = Array
+ structure LargeWordArraySlice = ArraySlice
+ structure LargeWordArray2 = Array2
+end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/sequence.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/sequence.fun 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/sequence.fun 2006-05-06 18:44:35 UTC (rev 4468)
@@ -12,165 +12,329 @@
(* fromArray should be constant time. *)
val fromArray: 'a elt array -> 'a sequence
val isMutable: bool
- val length: 'a sequence -> int
- val sub: 'a sequence * int -> 'a elt
+ val length: 'a sequence -> SeqIndex.int
+ val subUnsafe: 'a sequence * SeqIndex.int -> 'a elt
end
): SEQUENCE =
struct
- open S
-
structure Array = Primitive.Array
- open Primitive.Int
+ val op +? = SeqIndex.+?
+ val op + = SeqIndex.+
+ val op -? = SeqIndex.-?
+ val op - = SeqIndex.-
+ val op < = SeqIndex.<
+ val op <= = SeqIndex.<=
+ val op > = SeqIndex.>
+ val op >= = SeqIndex.>=
+ val ltu = SeqIndex.ltu
+ val leu = SeqIndex.leu
+ val gtu = SeqIndex.gtu
+ val geu = SeqIndex.geu
- val maxLen = Array.maxLen
+ fun wrap1 f = fn (i) => f (SeqIndex.toIntUnsafe i)
+ fun wrap2 f = fn (i, x) => f (SeqIndex.toIntUnsafe i, x)
+ fun wrap3 f = fn (i, x, y) => f (SeqIndex.toIntUnsafe i, x, y)
+ fun unwrap1 f = fn (i) => f (SeqIndex.fromIntUnsafe i)
+ fun unwrap2 f = fn (i, x) => f (SeqIndex.fromIntUnsafe i, x)
- fun array n =
- if not isMutable andalso n = 0
+ type 'a sequence = 'a S.sequence
+ type 'a elt = 'a S.elt
+
+ (*
+ * In general, *' values are in terms of SeqIndex.int,
+ * while * values are in terms of Int.int.
+ *)
+
+ local
+ fun doit (toInt, fromInt, maxInt') =
+ (Array.maxLen', toInt Array.maxLen')
+ handle Overflow => (fromInt maxInt', maxInt')
+ structure S =
+ Int_ChooseInt
+ (type 'a t = SeqIndex.int * 'a
+ val fInt8 = doit (SeqIndex.toInt8, SeqIndex.fromInt8,
+ Primitive.Int8.maxInt')
+ val fInt16 = doit (SeqIndex.toInt16, SeqIndex.fromInt16,
+ Primitive.Int16.maxInt')
+ val fInt32 = doit (SeqIndex.toInt32, SeqIndex.fromInt32,
+ Primitive.Int32.maxInt')
+ val fInt64 = doit (SeqIndex.toInt64, SeqIndex.fromInt64,
+ Primitive.Int64.maxInt')
+ val fIntInf = (Array.maxLen', SeqIndex.toIntInf Array.maxLen'))
+ in
+ val (maxLen', maxLen) = S.f
+ end
+
+ fun fromIntForLength n =
+ if Primitive.Controls.safe
+ then (SeqIndex.fromInt n) handle Overflow => raise Size
+ else SeqIndex.fromIntUnsafe n
+
+ fun length' s = S.length s
+ fun length s =
+ if Primitive.Controls.safe
+ then (SeqIndex.toInt (length' s))
+ handle Overflow => raise Fail "Sequence.length"
+ else SeqIndex.toIntUnsafe (length' s)
+
+ fun arrayUninit' n =
+ if not S.isMutable andalso n = 0
then Array.array0Const ()
- else Array.array n
+ else if Primitive.Controls.safe
+ andalso (n < 0 orelse n > maxLen')
+ then raise Size
+ else Array.arrayUnsafe n
+ fun arrayUninit n = arrayUninit' (fromIntForLength n)
- fun seq0 () = fromArray (array 0)
+ fun newUninit' n = S.fromArray (arrayUninit' n)
+ fun newUninit n = S.fromArray (arrayUninit n)
- (* unfoldi depends on the fact that the runtime system fills in the array
- * with reasonable bogus values.
- *)
- fun unfoldi (n, b, f) =
+ fun seq0 () = S.fromArray (arrayUninit' 0)
+
+ fun generate' (n, f) =
let
- val a = array n
+ val a = arrayUninit' n
+ val subLim = ref 0
+ fun sub i =
+ if Primitive.Controls.safe andalso geu (i, !subLim)
+ then raise Subscript
+ else Array.subUnsafe (a, i)
+ val updateLim = ref 0
+ fun update (i, x) =
+ if Primitive.Controls.safe andalso geu (i, !updateLim)
+ then raise Subscript
+ else Array.updateUnsafe (a, i, x)
+ val (tab, finish) = f {sub = sub, update = update}
+ fun loop i =
+ if i >= n
+ then ()
+ else let
+ val () = Array.updateUnsafe (a, i, tab i)
+ val () = subLim := i +? 1
+ val () = updateLim := i +? 1
+ in
+ loop (i +? 1)
+ end
+ val () = loop 0
+ val () = finish ()
+ val () = updateLim := 0
+ in
+ S.fromArray a
+ end
+ fun generate (n, f) =
+ generate' (fromIntForLength n,
+ fn {sub, update} =>
+ let
+ val (tab, finish) =
+ f {sub = unwrap1 sub, update = unwrap2 update}
+ in
+ (wrap1 tab, finish)
+ end)
+
+ fun unfoldi' (n, b, f) =
+ let
+ val a = arrayUninit' n
fun loop (i, b) =
- if i >= n then
- b
+ if i >= n
+ then b
else
let
val (x, b') = f (i, b)
- val () = Array.update (a, i, x)
+ val () = Array.updateUnsafe (a, i, x)
in
loop (i +? 1, b')
end
val b = loop (0, b)
in
- (fromArray a, b)
+ (S.fromArray a, b)
end
+ fun unfoldi (n, b, f) = unfoldi' (fromIntForLength n, b, wrap2 f)
+ fun unfold (n, b, f) = unfoldi (n, b, f o #2)
- fun tabulate (n, f) = #1 (unfoldi (n, (), fn (i, ()) => (f i, ())))
+ fun tabulate' (n, f) =
+ #1 (unfoldi' (n, (), fn (i, ()) => (f i, ())))
+ fun tabulate (n, f) =
+ #1 (unfoldi (n, (), fn (i, ()) => (f i, ())))
+ fun new' (n, x) = tabulate' (n, fn _ => x)
fun new (n, x) = tabulate (n, fn _ => x)
fun fromList l =
let
- val a = array (List.length l)
+ val a = arrayUninit (List.length l)
val _ =
- List.foldl (fn (c, i) => (Array.update (a, i, c) ; i +? 1)) 0 l
+ List.foldl (fn (x, i) => (Array.updateUnsafe (a, i, x) ; (i +? 1))) 0 l
in
- fromArray a
+ S.fromArray a
end
structure Slice =
struct
- type 'a sequence = 'a sequence
- type 'a elt = 'a elt
- datatype 'a t = T of {seq: 'a sequence, start: int, len: int}
+ type 'a sequence = 'a S.sequence
+ type 'a elt = 'a S.elt
+ datatype 'a t = T of {seq: 'a sequence,
+ start: SeqIndex.int, len: SeqIndex.int}
type 'a slice = 'a t
- fun length (T {len, ...}) = len
- fun unsafeSub (T {seq, start, ...}, i) =
- S.sub (seq, start +? i)
- fun sub (sl as T {len, ...}, i) =
- if Primitive.safe andalso Primitive.Int.geu (i, len)
+ fun length' (T {len, ...}) = len
+ fun length sl =
+ if Primitive.Controls.safe
+ then (SeqIndex.toInt (length' sl))
+ handle Overflow => raise Fail "Sequence.Slice.length"
+ else SeqIndex.toIntUnsafe (length' sl)
+ fun unsafeSub' (T {seq, start, ...}, i) =
+ S.subUnsafe (seq, start +? i)
+ fun unsafeSub (sl, i) =
+ unsafeSub' (sl, SeqIndex.fromIntUnsafe i)
+ fun sub' (sl as T {len, ...}, i) =
+ if Primitive.Controls.safe andalso geu (i, len)
then raise Subscript
- else unsafeSub (sl, i)
- fun unsafeUpdate' update (T {seq, start, ...}, i, x) =
- update (seq, start +? i, x)
- fun update' update (sl as T {len, ...}, i, x) =
- if Primitive.safe andalso Primitive.Int.geu (i, len)
+ else unsafeSub' (sl, i)
+ fun sub (sl, i) =
+ if Primitive.Controls.safe
+ then let
+ val i =
+ (SeqIndex.fromInt i)
+ handle Overflow => raise Subscript
+ in
+ sub' (sl, i)
+ end
+ else unsafeSub (sl, i)
+ fun unsafeUpdateMk' updateUnsafe (T {seq, start, ...}, i, x) =
+ updateUnsafe (seq, start +? i, x)
+ fun unsafeUpdateMk updateUnsafe (sl, i, x) =
+ unsafeUpdateMk' updateUnsafe (sl, SeqIndex.fromIntUnsafe i, x)
+ fun updateMk' updateUnsafe (sl as T {len, ...}, i, x) =
+ if Primitive.Controls.safe andalso geu (i, len)
then raise Subscript
- else unsafeUpdate' update (sl, i, x)
+ else unsafeUpdateMk' updateUnsafe (sl, i, x)
+ fun updateMk updateUnsafe (sl, i, x) =
+ if Primitive.Controls.safe
+ then let
+ val i =
+ (SeqIndex.fromInt i)
+ handle Overflow => raise Subscript
+ in
+ updateMk' updateUnsafe (sl, i, x)
+ end
+ else unsafeUpdateMk updateUnsafe (sl, i, x)
fun full (seq: 'a sequence) : 'a slice =
T {seq = seq, start = 0, len = S.length seq}
- fun subslice (T {seq, start, len}, start', len') =
- case len' of
- NONE => if Primitive.safe andalso
- (start' < 0 orelse start' > len)
- then raise Subscript
- else T {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 T {seq = seq,
- start = start +? start',
- len = len'}
- fun unsafeSubslice (T {seq, start, len}, start', len') =
+ fun unsafeSubslice' (T {seq, start, len}, start', len') =
T {seq = seq,
start = start +? start',
len = (case len' of
NONE => len -? start'
| SOME len' => len')}
+ fun unsafeSubslice (sl, start, len) =
+ unsafeSubslice'
+ (sl, SeqIndex.fromIntUnsafe start,
+ Option.map SeqIndex.fromIntUnsafe len)
+ fun unsafeSlice' (seq, start, len) =
+ unsafeSubslice' (full seq, start, len)
+ fun unsafeSlice (seq, start, len) =
+ unsafeSubslice (full seq, start, len)
+ fun subslice' (T {seq, start, len}, start', len') =
+ case len' of
+ NONE =>
+ if Primitive.Controls.safe
+ andalso gtu (start', len)
+ then raise Subscript
+ else T {seq = seq,
+ start = start +? start',
+ len = len -? start'}
+ | SOME len' =>
+ if Primitive.Controls.safe
+ andalso (gtu (start', len)
+ orelse gtu (len', len -? start'))
+ then raise Subscript
+ else T {seq = seq,
+ start = start +? start',
+ len = len'}
+ fun subslice (sl, start, len) =
+ if Primitive.Controls.safe
+ then (subslice' (sl,
+ SeqIndex.fromInt start,
+ Option.map SeqIndex.fromInt len))
+ handle Overflow => raise Subscript
+ else unsafeSubslice (sl, start, len)
+ fun slice' (seq: 'a sequence, start, len) =
+ subslice' (full seq, start, 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 (T {seq, start, len}) = (seq, start, len)
+ fun base' (T {seq, start, len}) =
+ (seq, start, len)
+ fun base (T {seq, start, len}) =
+ (seq, SeqIndex.toIntUnsafe start, SeqIndex.toIntUnsafe len)
fun isEmpty sl = length sl = 0
fun getItem (sl as T {seq, start, len}) =
if isEmpty sl
then NONE
- else SOME (S.sub (seq, start),
+ else SOME (S.subUnsafe (seq, start),
T {seq = seq,
start = start +? 1,
len = len -? 1})
- fun foldli f b (T {seq, start, len}) =
+ fun foldli' f b (T {seq, start, len}) =
let
val min = start
+ val len = len -? 1
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))
+ if i > max then b
+ else loop (i +? 1, f (i -? min, S.subUnsafe (seq, i), b))
in loop (min, b)
end
- fun foldri f b (T {seq, start, len}) =
+ fun foldli f b sl = foldli' (wrap3 f) b sl
+ fun foldri' f b (T {seq, start, len}) =
let
val min = start
+ val len = len -? 1
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)
+ else loop (i -? 1, f (i -? min, S.subUnsafe (seq, i), b))
+ in loop (max, b)
end
+ fun foldri f b sl = foldri' (wrap3 f) b sl
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
+ 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 appi' f sl = foldli' (fn (i, x, ()) => f (i, x)) () sl
+ fun appi f sl = appi' (wrap2 f) sl
fun app f sl = appi (f o #2) sl
- fun createi tabulate f (T {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 createi' tabulate' f (T {seq, start, len}) =
+ tabulate' (len, fn i => f (i, S.subUnsafe (seq, start +? i)))
+ fun createi tabulate' f sl = createi' tabulate' (wrap2 f) sl
+ fun create tabulate' f sl = createi tabulate' (f o #2) sl
+ fun mapi' f sl = createi' tabulate' f sl
+ fun mapi f sl = mapi' (wrap2 f) sl
fun map f sl = mapi (f o #2) sl
- fun findi p (T {seq, start, len}) =
+ fun findi' p (T {seq, start, len}) =
let
val min = start
+ val len = len -? 1
val max = start +? len
fun loop i =
- if i >= max
+ if i > max
then NONE
- else let val z = (i -? min, S.sub (seq, i))
+ else let val z = (i -? min, S.subUnsafe (seq, i))
in if p z
then SOME z
else loop (i +? 1)
end
in loop min
end
+ fun findi p sl = Option.map (wrap2 (fn z => z)) (findi' (wrap2 p) sl)
fun find p sl = Option.map #2 (findi (p o #2) sl)
- fun existsi p sl = Option.isSome (findi p sl)
+ fun existsi' p sl = Option.isSome (findi' p sl)
+ fun existsi p sl = existsi' (wrap2 p) sl
fun exists p sl = existsi (p o #2) sl
- fun alli p sl = not (existsi (not o p) sl)
+ fun alli' p sl = not (existsi' (not o p) sl)
+ fun alli p sl = alli' (wrap2 p) sl
fun all p sl = alli (p o #2) sl
fun collate cmp (T {seq = seq1, start = start1, len = len1},
T {seq = seq2, start = start2, len = len2}) =
@@ -185,32 +349,34 @@
| (true, false) => LESS
| (false, true) => GREATER
| (false, false) =>
- (case cmp (S.sub (seq1, i), S.sub (seq2, j)) of
+ (case cmp (S.subUnsafe (seq1, i),
+ S.subUnsafe (seq2, j)) of
EQUAL => loop (i +? 1, j +? 1)
| ans => ans)
in loop (min1, min2)
end
fun sequence (sl as T {seq, start, len}): 'a sequence =
- if isMutable orelse (start <> 0 orelse len <> S.length seq) then
- map (fn x => x) sl
- else
- seq
+ if S.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
+ 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
+ val l1 = length' sl1
+ val l2 = length' sl2
+ val n = (l1 + l2) handle Overflow => raise Size
in
- #1 (unfoldi (n, (0, sl1),
- fn (_, (i, sl)) =>
- if i < length sl then
- (unsafeSub (sl, i), (i +? 1, sl))
- else (unsafeSub (sl2, 0), (1, sl2))))
+ #1 (unfoldi'
+ (n, (0, sl1), fn (_, (i, sl)) =>
+ if SeqIndex.< (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
@@ -218,22 +384,22 @@
| [sl] => sequence sl
| sls' as sl::sls =>
let
- val n = List.foldl (fn (sl, s) => s + length sl) 0 sls'
- handle Overflow => raise Size
+ val n =
+ (List.foldl (fn (sl, s) => s +? length' sl) 0 sls')
+ handle Overflow => raise Size
in
- #1 (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))
+ #1 (unfoldi'
+ (n, (0, sl, sls), fn (_, ac) =>
+ let
+ fun loop (i, sl, sls) =
+ if SeqIndex.< (i, length' sl)
+ then (unsafeSub' (sl, i),
+ (i +? 1, sl, sls))
+ else case sls of
+ [] => raise Fail "Sequence.Slice.concat"
+ | 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
@@ -246,26 +412,41 @@
(sequence sl) sls
end
fun triml k =
- if Primitive.safe andalso k < 0
+ if Primitive.Controls.safe andalso Int.< (k, 0)
then raise Subscript
else
(fn (T {seq, start, len}) =>
- if k > len
- then unsafeSlice (seq, start +? len, SOME 0)
- else unsafeSlice (seq, start +? k, SOME (len -? k)))
+ let
+ val k =
+ if Primitive.Controls.safe
+ then SeqIndex.fromInt k
+ else SeqIndex.fromIntUnsafe k
+ in
+ if SeqIndex.> (k, len)
+ then unsafeSlice' (seq, start +? len, SOME 0)
+ else unsafeSlice' (seq, start +? k, SOME (len -? k))
+ end handle Overflow => unsafeSlice' (seq, start +? len, SOME 0))
fun trimr k =
- if Primitive.safe andalso k < 0
+ if Primitive.Controls.safe andalso Int.< (k, 0)
then raise Subscript
else
(fn (T {seq, start, len}) =>
- unsafeSlice (seq, start,
- SOME (if k > len then 0 else len -? k)))
+ let
+ val k =
+ if Primitive.Controls.safe
+ then SeqIndex.fromInt k
+ else SeqIndex.fromIntUnsafe k
+ in
+ if SeqIndex.> (k, len)
+ then unsafeSlice' (seq, start, SOME 0)
+ else unsafeSlice' (seq, start, SOME (len -? k))
+ end handle Overflow => unsafeSlice' (seq, start, SOME 0))
fun isSubsequence (eq: 'a elt * 'a elt -> bool)
(seq: 'a sequence)
(sl: 'a slice) =
let
val n = S.length seq
- val n' = length sl
+ val n' = length' sl
in
if n <= n'
then let
@@ -275,7 +456,8 @@
then false
else if j >= n
then true
- else if eq (S.sub (seq, j), unsafeSub (sl, i +? j))
+ else if eq (S.subUnsafe (seq, j),
+ unsafeSub' (sl, i +? j))
then loop (i, j +? 1)
else loop (i +? 1, 0)
in
@@ -288,14 +470,15 @@
(sl: 'a slice) =
let
val n = S.length seq
- val n' = length sl
+ 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))
+ else if eq (S.subUnsafe (seq, j),
+ unsafeSub' (sl, j))
then loop (j +? 1)
else false
in
@@ -308,7 +491,7 @@
(sl: 'a slice) =
let
val n = S.length seq
- val n' = length sl
+ val n' = length' sl
in
if n <= n'
then let
@@ -316,7 +499,8 @@
fun loop (j) =
if j >= n
then true
- else if eq (S.sub (seq, j), unsafeSub (sl, n'' +? j))
+ else if eq (S.subUnsafe (seq, j),
+ unsafeSub' (sl, n'' +? j))
then loop (j +? 1)
else false
in
@@ -324,35 +508,40 @@
end
else false
end
- fun split (T {seq, start, len}, i) =
- (unsafeSlice (seq, start, SOME (i -? start)),
- unsafeSlice (seq, i, SOME (len -? (i -? start))))
+ fun split' (T {seq, start, len}, i) =
+ (unsafeSlice' (seq, start, SOME (i -? start)),
+ unsafeSlice' (seq, i, SOME (len -? (i -? start))))
fun splitl f (sl as T {seq, start, len}) =
let
val stop = start +? len
fun loop i =
if i >= stop
then i
- else if f (S.sub (seq, i))
+ else if f (S.subUnsafe (seq, i))
then loop (i +? 1)
else i
- in split (sl, loop start)
+ in split' (sl, loop start)
end
fun splitr f (sl as T {seq, start, len}) =
let
fun loop i =
if i < start
then start
- else if f (S.sub (seq, i))
+ else if f (S.subUnsafe (seq, i))
then loop (i -? 1)
else i +? 1
- in split (sl, loop (start +? len -? 1))
+ in split' (sl, loop (start +? len -? 1))
end
- fun splitAt (T {seq, start, len}, i) =
- if Primitive.safe andalso Primitive.Int.gtu (i, len)
+ fun splitAt' (T {seq, start, len}, i) =
+ if Primitive.Controls.safe andalso SeqIndex.gtu (i, len)
then raise Subscript
- else (unsafeSlice (seq, start, SOME i),
- unsafeSlice (seq, start +? i, SOME (len -? i)))
+ else (unsafeSlice' (seq, start, SOME i),
+ unsafeSlice' (seq, start +? i, SOME (len -? i)))
+ fun splitAt (sl, i) =
+ if Primitive.Controls.safe
+ then (splitAt' (sl, SeqIndex.fromInt i))
+ handle Overflow => raise Subscript
+ else splitAt' (sl, SeqIndex.fromIntUnsafe 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)
@@ -371,21 +560,21 @@
fun loop' j =
if j >= len'
then i
- else if eq (S.sub (seq, i +? j),
- S.sub (seq', j))
+ else if eq (S.subUnsafe (seq, i +? j),
+ S.subUnsafe (seq', j))
then loop' (j +? 1)
else loop (i +? 1)
in loop' 0
end
- in split (sl, loop start)
+ in split' (sl, loop start)
end
fun span (eq: 'a sequence * 'a sequence -> bool)
(T {seq, start, ...},
T {seq = seq', start = start', len = len'}) =
- if Primitive.safe andalso
+ if Primitive.Controls.safe andalso
(not (eq (seq, seq')) orelse start' +? len' < start)
then raise Span
- else unsafeSlice (seq, start, SOME ((start' +? len') -? start))
+ 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
@@ -396,7 +585,7 @@
if i >= max
then List.rev (finish (seq, start, i, sls))
else
- if p (S.sub (seq, i))
+ if p (S.subUnsafe (seq, i))
then loop (i +? 1, i +? 1, finish (seq, start, i, sls))
else loop (i +? 1, start, sls)
in loop (start, start, [])
@@ -407,12 +596,12 @@
if start = stop
then sls
else
- (unsafeSlice (seq, start, SOME (stop -? start)))
+ (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)))
+ (unsafeSlice' (seq, start, SOME (stop -? start)))
:: sls)
p sl
end
@@ -424,23 +613,38 @@
fun make2 f (seq1, seq2) = f (Slice.full seq1, Slice.full seq2)
in
fun sub (seq, i) = Slice.sub (Slice.full seq, i)
+ 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 unsafeSub' (seq, i) = Slice.unsafeSub' (Slice.full seq, i)
+ fun updateMk updateUnsafe (seq, i, x) =
+ Slice.updateMk updateUnsafe (Slice.full seq, i, x)
+ fun updateMk' updateUnsafe (seq, i, x) =
+ Slice.updateMk' updateUnsafe (Slice.full seq, i, x)
+ fun unsafeUpdateMk updateUnsafe (seq, i, x) =
+ Slice.unsafeUpdateMk updateUnsafe (Slice.full seq, i, x)
+ fun unsafeUpdateMk' updateUnsafe (seq, i, x) =
+ Slice.unsafeUpdateMk' updateUnsafe (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 appi f = make (Slice.appi f)
fun app f = make (Slice.app f)
+ fun mapi' f = make (Slice.mapi' 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 foldli f b = make (Slice.foldli f b)
+ fun foldl f b = make (Slice.foldl f b)
+ fun foldri' f b = make (Slice.foldri' 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 findi p = make (Slice.findi p)
fun find p = make (Slice.find p)
+ fun existsi' p = make (Slice.existsi' p)
fun existsi p = make (Slice.existsi p)
fun exists p = make (Slice.exists p)
+ fun alli' p = make (Slice.alli' p)
fun alli p = make (Slice.alli p)
fun all p = make (Slice.all p)
fun collate cmp = make2 (Slice.collate cmp)
@@ -451,8 +655,9 @@
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 createi' tabulate' f seq = make (Slice.createi' tabulate' 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
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/sequence.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/sequence.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/sequence.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -16,27 +16,45 @@
val maxLen: int
val fromList: 'a elt list -> 'a sequence
+ val tabulate': SeqIndex.int * (SeqIndex.int -> 'a elt) -> 'a sequence
val tabulate: int * (int -> 'a elt) -> 'a sequence
+ val length': 'a sequence -> SeqIndex.int
val length: 'a sequence -> int
+ val sub': 'a sequence * SeqIndex.int -> 'a elt
val sub: 'a sequence * int -> 'a elt
+ val unsafeSub': 'a sequence * SeqIndex.int -> 'a elt
val unsafeSub: 'a sequence * int -> 'a elt
- (* ('a sequence * int * 'a elt -> unit should be an unsafe update.
+ (* updateMk',updateMk,unsafeUpdateMk',unsafeUpdateMk:
+ * ('a sequence * SeqIndex.int * 'a elt -> unit) should be an unsafe update.
*)
- val update': ('a sequence * int * 'a elt -> unit) ->
- ('a sequence * int * 'a elt) -> unit
+ val updateMk': ('a sequence * SeqIndex.int * 'a elt -> unit) ->
+ ('a sequence * SeqIndex.int * 'a elt) -> unit
+ val updateMk: ('a sequence * SeqIndex.int * 'a elt -> unit) ->
+ ('a sequence * int * 'a elt) -> unit
+ val unsafeUpdateMk': ('a sequence * SeqIndex.int * 'a elt -> unit) ->
+ ('a sequence * SeqIndex.int * 'a elt) -> unit
+ val unsafeUpdateMk: ('a sequence * SeqIndex.int * 'a elt -> unit) ->
+ ('a sequence * int * 'a elt) -> unit
val concat: 'a sequence list -> 'a sequence
+ val appi': (SeqIndex.int * 'a elt -> unit) -> 'a sequence -> unit
val appi: (int * 'a elt -> unit) -> 'a sequence -> unit
val app: ('a elt -> unit) -> 'a sequence -> unit
+ val mapi' : (SeqIndex.int * 'a elt -> 'b elt) -> 'a sequence -> 'b sequence
val mapi : (int * 'a elt -> 'b elt) -> 'a sequence -> 'b sequence
val map: ('a elt -> 'b elt) -> 'a sequence -> 'b sequence
+ val foldli': (SeqIndex.int * 'a elt * 'b -> 'b) -> 'b -> 'a sequence -> 'b
val foldli: (int * 'a elt * 'b -> 'b) -> 'b -> 'a sequence -> 'b
+ val foldl: ('a elt * 'b -> 'b) -> 'b -> 'a sequence -> 'b
+ val foldri': (SeqIndex.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 foldr: ('a elt * 'b -> 'b) -> 'b -> 'a sequence -> 'b
+ val findi': (SeqIndex.int * 'a elt -> bool) -> 'a sequence -> (SeqIndex.int * 'a elt) option
val findi: (int * 'a elt -> bool) -> 'a sequence -> (int * 'a elt) option
val find: ('a elt -> bool) -> 'a sequence -> 'a elt option
+ val existsi': (SeqIndex.int * 'a elt -> bool) -> 'a sequence -> bool
val existsi: (int * 'a elt -> bool) -> 'a sequence -> bool
val exists: ('a elt -> bool) -> 'a sequence -> bool
+ val alli': (SeqIndex.int * '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
@@ -52,15 +70,32 @@
(* Extra *)
val append: 'a sequence * 'a sequence -> 'a sequence
- (* createi,create:
- * (int * (int -> 'b elt) -> 'c should be a tabulate function.
+ (* createi',createi,create:
+ * (SeqIndex.int * (SeqIndex.int -> 'b elt) -> 'c) should be a tabulate' function.
*)
- val createi: (int * (int -> 'b elt) -> 'c) ->
+ val createi': (SeqIndex.int * (SeqIndex.int -> 'b elt) -> 'c) ->
+ (SeqIndex.int * 'a elt -> 'b elt) -> 'a sequence -> 'c
+ val createi: (SeqIndex.int * (SeqIndex.int -> 'b elt) -> 'c) ->
(int * 'a elt -> 'b elt) -> 'a sequence -> 'c
- val create: (int * (int -> 'b elt) -> 'c) ->
+ val create: (SeqIndex.int * (SeqIndex.int -> 'b elt) -> 'c) ->
('a elt -> 'b elt) -> 'a sequence -> 'c
val duplicate: 'a sequence -> 'a sequence
+ val generate':
+ SeqIndex.int * ({sub: SeqIndex.int -> 'a elt,
+ update: SeqIndex.int * 'a elt -> unit}
+ -> (SeqIndex.int -> 'a elt) * (unit -> unit))
+ -> 'a sequence
+ val generate:
+ int * ({sub: int -> 'a elt,
+ update: int * 'a elt -> unit}
+ -> (int -> 'a elt) * (unit -> unit))
+ -> 'a sequence
+ val newUninit': SeqIndex.int -> 'a sequence
+ val newUninit: int -> 'a sequence
+ val new': SeqIndex.int * 'a elt -> 'a sequence
val new: int * 'a elt -> 'a sequence
val toList: 'a sequence -> 'a elt list
- val unfoldi: int * 'a * (int * 'a -> 'b elt * 'a) -> 'b sequence * 'a
+ val unfoldi': SeqIndex.int * 'b * (SeqIndex.int * 'b -> 'a elt * 'b) -> 'a sequence * 'b
+ val unfoldi: int * 'b * (int * 'b -> 'a elt * 'b) -> 'a sequence * 'b
+ val unfold: int * 'b * ('b -> 'a elt * 'b) -> 'a sequence * 'b
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/slice.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/slice.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/slice.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -11,36 +11,56 @@
type 'a sequence
type 'a elt
type 'a slice
+ val length': 'a slice -> SeqIndex.int
val length: 'a slice -> int
+ val sub': 'a slice * SeqIndex.int -> 'a elt
val sub: 'a slice * int -> 'a elt
+ val unsafeSub': 'a slice * SeqIndex.int -> 'a elt
val unsafeSub: 'a slice * int -> 'a elt
- (* ('a sequence * int * 'a elt -> unit should be an unsafe update.
+ (* updateMk',updateMk,unsafeUpdateMk',unsafeUpdateMk:
+ * ('a sequence * SeqIndex.int * 'a elt -> unit) should be an unsafe update.
*)
- val update': ('a sequence * int * 'a elt -> unit) ->
- ('a slice * int * 'a elt) -> unit
- val unsafeUpdate': ('a sequence * int * 'a elt -> unit) ->
- ('a slice * int * 'a elt) -> unit
+ val updateMk': ('a sequence * SeqIndex.int * 'a elt -> unit) ->
+ ('a slice * SeqIndex.int * 'a elt) -> unit
+ val updateMk: ('a sequence * SeqIndex.int * 'a elt -> unit) ->
+ ('a slice * int * 'a elt) -> unit
+ val unsafeUpdateMk': ('a sequence * SeqIndex.int * 'a elt -> unit) ->
+ ('a slice * SeqIndex.int * 'a elt) -> unit
+ val unsafeUpdateMk: ('a sequence * SeqIndex.int * 'a elt -> unit) ->
+ ('a slice * int * 'a elt) -> unit
val full: 'a sequence -> 'a slice
+ val slice': 'a sequence * SeqIndex.int * SeqIndex.int option -> 'a slice
val slice: 'a sequence * int * int option -> 'a slice
+ val unsafeSlice': 'a sequence * SeqIndex.int * SeqIndex.int option -> 'a slice
val unsafeSlice: 'a sequence * int * int option -> 'a slice
+ val subslice': 'a slice * SeqIndex.int * SeqIndex.int option -> 'a slice
val subslice: 'a slice * int * int option -> 'a slice
+ val unsafeSubslice': 'a slice * SeqIndex.int * SeqIndex.int option -> 'a slice
val unsafeSubslice: 'a slice * int * int option -> 'a slice
+ val base': 'a slice -> 'a sequence * SeqIndex.int * SeqIndex.int
val base: 'a slice -> 'a sequence * int * int
val concat: 'a slice list -> 'a sequence
val isEmpty: 'a slice -> bool
val getItem: 'a slice -> ('a elt * 'a slice) option
+ val appi': (SeqIndex.int * 'a elt -> unit) -> 'a slice -> unit
val appi: (int * 'a elt -> unit) -> 'a slice -> unit
val app: ('a elt -> unit) -> 'a slice -> unit
+ val mapi': (SeqIndex.int * 'a elt -> 'b elt) -> 'a slice -> 'b sequence
val mapi: (int * 'a elt -> 'b elt) -> 'a slice -> 'b sequence
val map: ('a elt -> 'b elt) -> 'a slice -> 'b sequence
+ val foldli': (SeqIndex.int * 'a elt * 'b -> 'b) -> 'b -> 'a slice -> 'b
val foldli: (int * 'a elt * 'b -> 'b) -> 'b -> 'a slice -> 'b
+ val foldl: ('a elt * 'b -> 'b) -> 'b -> 'a slice -> 'b
+ val foldri': (SeqIndex.int * 'a elt * 'b -> 'b) -> 'b -> 'a slice -> 'b
val foldri: (int * 'a elt * 'b -> 'b) -> 'b -> 'a slice -> 'b
- val foldl: ('a elt * 'b -> 'b) -> 'b -> 'a slice -> 'b
val foldr: ('a elt * 'b -> 'b) -> 'b -> 'a slice -> 'b
+ val findi': (SeqIndex.int * 'a elt -> bool) -> 'a slice -> (SeqIndex.int * 'a elt) option
val findi: (int * 'a elt -> bool) -> 'a slice -> (int * 'a elt) option
val find: ('a elt -> bool) -> 'a slice -> 'a elt option
+ val existsi': (SeqIndex.int * 'a elt -> bool) -> 'a slice -> bool
val existsi: (int * 'a elt -> bool) -> 'a slice -> bool
val exists: ('a elt -> bool) -> 'a slice -> bool
+ val alli': (SeqIndex.int * 'a elt -> bool) -> 'a slice -> bool
val alli: (int * 'a elt -> bool) -> 'a slice -> bool
val all: ('a elt -> bool) -> 'a slice -> bool
val collate: ('a elt * 'a elt -> order) -> 'a slice * 'a slice -> order
@@ -54,6 +74,7 @@
val isSuffix: ('a elt * 'a elt -> bool) -> 'a sequence -> 'a slice -> bool
val splitl: ('a elt -> bool) -> 'a slice -> 'a slice * 'a slice
val splitr: ('a elt -> bool) -> 'a slice -> 'a slice * 'a slice
+ val splitAt': 'a slice * SeqIndex.int -> 'a slice * 'a slice
val splitAt: 'a slice * int -> 'a slice * 'a slice
val dropl: ('a elt -> bool) -> 'a slice -> 'a slice
val dropr: ('a elt -> bool) -> 'a slice -> 'a slice
@@ -62,7 +83,7 @@
val position: ('a elt * 'a elt -> bool) ->
'a sequence -> 'a slice -> 'a slice * 'a slice
(* span:
- * 'a sequence * 'a sequence -> bool should be polymorphic equality
+ * ('a sequence * 'a sequence -> bool) should be polymorphic equality
*)
val span: ('a sequence * 'a sequence -> bool) -> 'a slice * 'a slice -> 'a slice
val translate: ('a elt -> 'a sequence) -> 'a slice -> 'a sequence
@@ -71,12 +92,14 @@
(* Extra *)
val append: 'a slice * 'a slice -> 'a sequence
- (* createi,create:
- * (int * (int -> 'b elt) -> 'c should be a tabulate function.
+ (* createi',createi,create:
+ * (SeqIndex.int * (SeqIndex.int -> 'b elt) -> 'c) should be a tabulate' function.
*)
- val createi: (int * (int -> 'b elt) -> 'c) ->
+ val createi': (SeqIndex.int * (SeqIndex.int -> 'b elt) -> 'c) ->
+ (SeqIndex.int * 'a elt -> 'b elt) -> 'a slice -> 'c
+ val createi: (SeqIndex.int * (SeqIndex.int -> 'b elt) -> 'c) ->
(int * 'a elt -> 'b elt) -> 'a slice -> 'c
- val create: (int * (int -> 'b elt) -> 'c) ->
+ val create: (SeqIndex.int * (SeqIndex.int -> 'b elt) -> 'c) ->
('a elt -> 'b elt) -> 'a slice -> 'c
val toList: 'a slice -> 'a elt list
val sequence: 'a slice -> 'a sequence
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/vector-slice.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/vector-slice.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/vector-slice.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -5,7 +5,6 @@
signature VECTOR_SLICE_GLOBAL =
sig
-
end
signature VECTOR_SLICE =
@@ -27,10 +26,10 @@
val appi: (int * 'a -> unit) -> 'a slice -> unit
val app: ('a -> unit) -> 'a slice -> unit
val mapi: (int * 'a -> 'b) -> 'a slice -> 'b Vector.vector
- val map: ('a -> 'b) -> 'a slice -> 'b Vector.vector
+ val map: ('a -> 'b) -> 'a slice -> 'b Vector.vector
val foldli: (int * 'a * 'b -> 'b) -> 'b -> 'a slice -> 'b
+ val foldl: ('a * 'b -> 'b) -> 'b -> 'a slice -> 'b
val foldri: (int * 'a * 'b -> 'b) -> 'b -> 'a slice -> 'b
- val foldl: ('a * 'b -> 'b) -> 'b -> 'a slice -> 'b
val foldr: ('a * 'b -> 'b) -> 'b -> 'a slice -> 'b
val findi: (int * 'a -> bool) -> 'a slice -> (int * 'a) option
val find: ('a -> bool) -> 'a slice -> 'a option
@@ -43,8 +42,11 @@
sig
include VECTOR_SLICE
+ val unsafeSub': 'a slice * SeqIndex.int -> 'a
val unsafeSub: 'a slice * int -> 'a
+ val unsafeSlice': 'a Vector.vector * SeqIndex.int * SeqIndex.int option -> 'a slice
val unsafeSlice: 'a Vector.vector * int * int option -> 'a slice
+ val unsafeSubslice': 'a slice * SeqIndex.int * SeqIndex.int option -> 'a slice
val unsafeSubslice: 'a slice * int * int option -> 'a slice
(* Used to implement Substring/String functions *)
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/vector.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/vector.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/vector.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -34,24 +34,26 @@
include VECTOR
structure VectorSlice: VECTOR_SLICE_EXTRA
- val append: 'a vector * 'a vector -> 'a vector
- (* concatWith is used to implement Substring/String functions *)
+ val fromArray: 'a array -> 'a vector
+ val unsafeSub: 'a vector * int -> 'a
+
+ (* Used to implement Substring/String functions *)
val concatWith: 'a vector -> 'a vector list -> 'a vector
- val create:
- int
- * ({sub: int -> 'a, update: int * 'a -> unit}
- -> (int -> 'a) * (unit -> unit))
- -> 'a vector
- val duplicate: 'a vector -> 'a vector
- val fields: ('a -> bool) -> 'a vector -> 'a vector list
- val fromArray: 'a array -> '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 create:
+ int * ({sub: int -> 'a, update: int * 'a -> unit}
+ -> (int -> 'a) * (unit -> unit))
+ -> 'a vector
+ val duplicate: 'a vector -> 'a vector
+ val tabulate': SeqIndex.int * (SeqIndex.int -> 'a) -> 'a vector
val toList: 'a vector -> 'a list
- val tokens: ('a -> bool) -> 'a vector -> 'a vector list
- val translate: ('a -> 'a vector) -> 'a vector -> 'a vector
val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a vector * 'b
- val unsafeSub: 'a vector * int -> 'a
val vector: int * 'a -> 'a vector
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/vector.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/vector.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/vector.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -13,7 +13,7 @@
val fromArray = Primitive.Vector.fromArray
val isMutable = false
val length = Primitive.Vector.length
- val sub = Primitive.Vector.sub)
+ val subUnsafe = Primitive.Vector.subUnsafe)
open V
type 'a vector = 'a vector
@@ -30,49 +30,41 @@
end
fun update (v, i, x) =
- tabulate (length v,
- fn j => if i = j
- then x
- else unsafeSub (v, j))
+ let
+ fun doit i =
+ tabulate' (length' v,
+ fn j => if i = j
+ then x
+ else unsafeSub' (v, j))
+ in
+ if Primitive.Controls.safe
+ then
+ let
+ val i =
+ (SeqIndex.fromInt i)
+ handle Overflow => raise Subscript
+ in
+ if SeqIndex.geu (i, length' v)
+ then raise Subscript
+ else doit i
+ end
+ else let
+ val i = SeqIndex.fromIntUnsafe i
+ in
+ doit i
+ end
+ end
- val unsafeSub = Primitive.Vector.sub
-
val isSubvector = isSubsequence
val fromArray = Primitive.Vector.fromArray
val vector = new
- fun create (n, f) =
- let
- val a = Primitive.Array.array n
- val subLim = ref 0
- fun sub i =
- if Primitive.safe andalso Primitive.Int.geu (i, !subLim) then
- raise Subscript
- else
- Primitive.Array.sub (a, i)
- val updateLim = ref 0
- fun update (i, x) =
- if Primitive.safe andalso Primitive.Int.geu (i, !updateLim) then
- raise Subscript
- else
- Primitive.Array.update (a, i, x)
- val (tab, finish) = f {sub = sub, update = update}
- val () =
- Util.naturalForeach
- (n, fn i =>
- (Primitive.Array.update (a, i, tab i);
- subLim := i + 1;
- updateLim := i + 1))
- val () = finish ()
- val () = updateLim := 0
- in
- fromArray a
- end
+ fun create (n, f) = generate (n, f)
end
structure VectorSlice: VECTOR_SLICE_EXTRA = Vector.VectorSlice
-
+
structure VectorGlobal: VECTOR_GLOBAL = Vector
open VectorGlobal
val vector = Vector.fromList
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/build (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/build)
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/config/bind (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind)
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/config/c/amd64-linux/c-types.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/config/c/amd64-linux/c-types.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/config/c/amd64-linux/c-types.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -44,9 +44,12 @@
structure C_Size = struct open Word32 type t = word end
functor C_Size_ChooseWordN (A: CHOOSE_WORDN_ARG) = ChooseWordN_Word32 (A)
-structure C_Pointer = Pointer
-structure C_String = Pointer
-structure C_StringArray = Pointer
+structure C_Pointer = struct open Word32 type t = word end
+functor C_Pointer_ChooseWordN (A: CHOOSE_WORDN_ARG) = ChooseWordN_Word32 (A)
+structure C_String = struct open Word32 type t = word end
+functor C_String_ChooseWordN (A: CHOOSE_WORDN_ARG) = ChooseWordN_Word32 (A)
+structure C_StringArray = struct open Word32 type t = word end
+functor C_StringArray_ChooseWordN (A: CHOOSE_WORDN_ARG) = ChooseWordN_Word32 (A)
(* Generic integers *)
structure C_Fd = C_Int
@@ -65,6 +68,10 @@
functor C_Intmax_ChooseIntN (A: CHOOSE_INTN_ARG) = ChooseIntN_Int64 (A)
structure C_UIntmax = struct open Word64 type t = word end
functor C_UIntmax_ChooseWordN (A: CHOOSE_WORDN_ARG) = ChooseWordN_Word64 (A)
+structure C_Intptr = struct open Int32 type t = int end
+functor C_Intptr_ChooseIntN (A: CHOOSE_INTN_ARG) = ChooseIntN_Int32 (A)
+structure C_UIntptr = struct open Word32 type t = word end
+functor C_UIntptr_ChooseWordN (A: CHOOSE_WORDN_ARG) = ChooseWordN_Word32 (A)
(* from <dirent.h> *)
structure C_DirP = struct open Word32 type t = word end
@@ -105,8 +112,6 @@
functor C_Time_ChooseIntN (A: CHOOSE_INTN_ARG) = ChooseIntN_Int32 (A)
structure C_UId = struct open Word32 type t = word end
functor C_UId_ChooseWordN (A: CHOOSE_WORDN_ARG) = ChooseWordN_Word32 (A)
-structure C_USeconds = struct open Word32 type t = word end
-functor C_USeconds_ChooseWordN (A: CHOOSE_WORDN_ARG) = ChooseWordN_Word32 (A)
(* from <sys/socket.h> *)
structure C_Socklen = struct open Word32 type t = word end
@@ -124,5 +129,3 @@
structure C_MPLimb = struct open Word32 type t = word end
functor C_MPLimb_ChooseWordN (A: CHOOSE_WORDN_ARG) = ChooseWordN_Word32 (A)
-
-structure C_Errno = struct type 'a t = 'a end
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/config/c/errno.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/errno.sml)
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/config/c/position.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/position.sml)
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/config/c/sys-word.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/sys-word.sml)
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/config/c/test (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/test)
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/config/c/x86-linux/c-types.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/config/c/x86-linux/c-types.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/config/c/x86-linux/c-types.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -44,9 +44,12 @@
structure C_Size = struct open Word32 type t = word end
functor C_Size_ChooseWordN (A: CHOOSE_WORDN_ARG) = ChooseWordN_Word32 (A)
-structure C_Pointer = Pointer
-structure C_String = Pointer
-structure C_StringArray = Pointer
+structure C_Pointer = struct open Word32 type t = word end
+functor C_Pointer_ChooseWordN (A: CHOOSE_WORDN_ARG) = ChooseWordN_Word32 (A)
+structure C_String = struct open Word32 type t = word end
+functor C_String_ChooseWordN (A: CHOOSE_WORDN_ARG) = ChooseWordN_Word32 (A)
+structure C_StringArray = struct open Word32 type t = word end
+functor C_StringArray_ChooseWordN (A: CHOOSE_WORDN_ARG) = ChooseWordN_Word32 (A)
(* Generic integers *)
structure C_Fd = C_Int
@@ -65,6 +68,10 @@
functor C_Intmax_ChooseIntN (A: CHOOSE_INTN_ARG) = ChooseIntN_Int64 (A)
structure C_UIntmax = struct open Word64 type t = word end
functor C_UIntmax_ChooseWordN (A: CHOOSE_WORDN_ARG) = ChooseWordN_Word64 (A)
+structure C_Intptr = struct open Int32 type t = int end
+functor C_Intptr_ChooseIntN (A: CHOOSE_INTN_ARG) = ChooseIntN_Int32 (A)
+structure C_UIntptr = struct open Word32 type t = word end
+functor C_UIntptr_ChooseWordN (A: CHOOSE_WORDN_ARG) = ChooseWordN_Word32 (A)
(* from <dirent.h> *)
structure C_DirP = struct open Word32 type t = word end
@@ -105,8 +112,6 @@
functor C_Time_ChooseIntN (A: CHOOSE_INTN_ARG) = ChooseIntN_Int32 (A)
structure C_UId = struct open Word32 type t = word end
functor C_UId_ChooseWordN (A: CHOOSE_WORDN_ARG) = ChooseWordN_Word32 (A)
-structure C_USeconds = struct open Word32 type t = word end
-functor C_USeconds_ChooseWordN (A: CHOOSE_WORDN_ARG) = ChooseWordN_Word32 (A)
(* from <sys/socket.h> *)
structure C_Socklen = struct open Word32 type t = word end
@@ -124,5 +129,3 @@
structure C_MPLimb = struct open Word32 type t = word end
functor C_MPLimb_ChooseWordN (A: CHOOSE_WORDN_ARG) = ChooseWordN_Word32 (A)
-
-structure C_Errno = struct type 'a t = 'a end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/config/choose.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/config/choose.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/config/choose.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -5,6 +5,24 @@
* See the file MLton-LICENSE for details.
*)
+signature CHOOSE_CHARN_ARG =
+ sig
+ type 'a t
+ val fChar8: Char8.char t
+ val fChar16: Char16.char t
+ val fChar32: Char32.char t
+ end
+
+functor ChooseCharN_Char8 (A : CHOOSE_CHARN_ARG) :
+ sig val f : Char8.char A.t end =
+ struct val f = A.fChar8 end
+functor ChooseCharN_Char16 (A : CHOOSE_CHARN_ARG) :
+ sig val f : Char16.char A.t end =
+ struct val f = A.fChar16 end
+functor ChooseCharN_Char32 (A : CHOOSE_CHARN_ARG) :
+ sig val f : Char32.char A.t end =
+ struct val f = A.fChar32 end
+
signature CHOOSE_INTN_ARG =
sig
type 'a t
@@ -27,6 +45,32 @@
sig val f : Int64.int A.t end =
struct val f = A.fInt64 end
+signature CHOOSE_INT_ARG =
+ sig
+ type 'a t
+ val fInt8: Int8.int t
+ val fInt16: Int16.int t
+ val fInt32: Int32.int t
+ val fInt64: Int64.int t
+ val fIntInf: IntInf.int t
+ end
+
+functor ChooseInt_Int8 (A : CHOOSE_INT_ARG) :
+ sig val f : Int8.int A.t end =
+ struct val f = A.fInt8 end
+functor ChooseInt_Int16 (A : CHOOSE_INT_ARG) :
+ sig val f : Int16.int A.t end =
+ struct val f = A.fInt16 end
+functor ChooseInt_Int32 (A : CHOOSE_INT_ARG) :
+ sig val f : Int32.int A.t end =
+ struct val f = A.fInt32 end
+functor ChooseInt_Int64 (A : CHOOSE_INT_ARG) :
+ sig val f : Int64.int A.t end =
+ struct val f = A.fInt64 end
+functor ChooseInt_IntInf (A : CHOOSE_INT_ARG) :
+ sig val f : IntInf.int A.t end =
+ struct val f = A.fIntInf end
+
signature CHOOSE_REALN_ARG =
sig
type 'a t
@@ -41,6 +85,24 @@
sig val f : Real64.real A.t end =
struct val f = A.fReal64 end
+signature CHOOSE_STRINGN_ARG =
+ sig
+ type 'a t
+ val fString8: String8.string t
+ val fString16: String16.string t
+ val fString32: String32.string t
+ end
+
+functor ChooseStringN_String8 (A : CHOOSE_STRINGN_ARG) :
+ sig val f : String8.string A.t end =
+ struct val f = A.fString8 end
+functor ChooseStringN_String16 (A : CHOOSE_STRINGN_ARG) :
+ sig val f : String16.string A.t end =
+ struct val f = A.fString16 end
+functor ChooseStringN_String32 (A : CHOOSE_STRINGN_ARG) :
+ sig val f : String32.string A.t end =
+ struct val f = A.fString32 end
+
signature CHOOSE_WORDN_ARG =
sig
type 'a t
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/config/default (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/default)
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/config/header (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/header)
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/config/objptr (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/objptr)
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/config/seqindex (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/seqindex)
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/general/general.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/general/general.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/general/general.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -8,21 +8,21 @@
structure General: GENERAL_EXTRA =
struct
- type unit = unit
+ type unit = Primitive.Unit.unit
type exn = exn
exception Bind = Bind
exception Match = Match
exception Chr
- exception Div
- exception Domain
- exception Fail = Fail
+ exception Div = Div
+ exception Domain = Domain
+ exception Fail of string
exception Overflow = Overflow
exception Size = Size
exception Span
- exception Subscript
+ exception Subscript = Subscript
- datatype order = LESS | EQUAL | GREATER
+ datatype order = datatype Primitive.Order.order
val ! = Primitive.Ref.deref
val op := = Primitive.Ref.assign
@@ -54,4 +54,3 @@
structure GeneralGlobal: GENERAL_GLOBAL = General
open GeneralGlobal
-
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/general/option.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/general/option.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/general/option.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -15,8 +15,7 @@
val app: ('a -> unit) -> 'a option -> unit
val compose: ('a -> 'b) * ('c -> 'a option) -> 'c -> 'b option
- val composePartial:
- ('a -> 'b option) * ('c -> 'a option) -> 'c -> 'b option
+ val composePartial: ('a -> 'b option) * ('c -> 'a option) -> 'c -> 'b option
val filter: ('a -> bool) -> 'a -> 'a option
val join: 'a option option -> 'a option
val map: ('a -> 'b) -> 'a option -> 'b option
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/integer/embed-int.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/integer/embed-int.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/integer/embed-int.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -10,7 +10,7 @@
eqtype int
type big
- val precision': Int.int
+ val precision': Int32.int
val fromBigUnsafe: big -> int
val toBig: int -> big
end
@@ -18,12 +18,18 @@
functor EmbedInt (structure Big: INTEGER_EXTRA
structure Small: EMBED_INT where type big = Big.int): INTEGER =
struct
- val () = if Int.< (Small.precision', valOf Big.precision) then ()
+ structure Small =
+ struct
+ open Small
+ val precision': Int.int = Int32.toInt precision'
+ end
+
+ val () = if Int.< (Small.precision', Big.precision') then ()
else raise Fail "EmbedWord"
open Small
- val shift = Word.fromInt (Int.- (valOf Big.precision, precision'))
+ val shift = Word.fromInt (Int.- (Big.precision', precision'))
val extend: Big.int -> Big.int =
fn i => Big.~>> (Big.<< (i, shift), shift)
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/integer/embed-word.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/integer/embed-word.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/integer/embed-word.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -12,12 +12,18 @@
val fromBigUnsafe: big -> word
val toBig: word -> big
- val wordSize: Int.int
+ val wordSize: Int32.int
end
functor EmbedWord (structure Big: WORD
structure Small: EMBED_WORD where type big = Big.word): WORD =
struct
+ structure Small =
+ struct
+ open Small
+ val wordSize: Int.int = Int32.toInt wordSize
+ end
+
val () = if Int.< (Small.wordSize, Big.wordSize) then ()
else raise Fail "EmbedWord"
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int-global.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/int-global.sml)
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int-inf.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int-inf.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int-inf.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -11,20 +11,32 @@
val andb: int * int -> int
val notb: int -> int
val << : int * Word.word -> int
- val ~>> : int * Word.word -> int
+ val ~>> : int * Word.word -> int
end
signature INT_INF_EXTRA =
sig
include INT_INF
+ type t = int
+ structure BigWord : WORD
+ structure SmallInt : INTEGER
+
val areSmall: int * int -> bool
- val fromInt64: Int64.int -> int
val gcd: int * int -> int
val isSmall: int -> bool
datatype rep =
- Big of Word.word Vector.vector
- | Small of Int.int
+ Big of BigWord.word Vector.vector
+ | Small of SmallInt.int
val rep: int -> rep
- val toInt64: int -> Int64.int
+
+ val +? : int * int -> int
+ val *? : int * int -> int
+ val -? : int * int -> int
+ val ~? : int -> int
+
+ val ltu: int * int -> bool
+ val leu: int * int -> bool
+ val gtu: int * int -> bool
+ val geu: int * int -> bool
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int-inf.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int-inf.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int-inf.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
*
@@ -6,627 +6,114 @@
* See the file MLton-LICENSE for details.
*)
-(*
- * IntInf.int's either have a bottom bit of 1, in which case the top 31
- * bits are the signed integer, or else the bottom bit is 0, in which case
- * they point to an vector of Word.word's. The first word is either 0,
- * indicating that the number is positive, or 1, indicating that it is
- * negative. The rest of the vector contains the `limbs' (big digits) of
- * the absolute value of the number, from least to most significant.
- *)
structure IntInf: INT_INF_EXTRA =
struct
- structure Word = Word32
-
- datatype rep =
- Big of Word.word Vector.vector
- | Small of Int.int
-
- structure Prim = Primitive.IntInf
- type bigInt = Prim.int
- local
- open Int
- in
- val op < = op <
- val op <= = op <=
- val op > = op >
- val op >= = op >=
- val op + = op +
- val op - = op -
- end
- type smallInt = int
-
- (* bigIntConstant is just to make it easy to spot where the bigInt
- * constants are in this module.
- *)
- fun bigIntConstant x = x
- val zero = bigIntConstant 0
- val one = bigIntConstant 1
- val negOne = bigIntConstant ~1
-
- (* Check if an IntInf.int is small (i.e., a fixnum). *)
- fun isSmall (i: bigInt): bool =
- 0w0 <> Word.andb (Prim.toWord i, 0w1)
+ open Primitive.IntInf
+ type t = int
- (* Check if two IntInf.int's are both small (i.e., fixnums).
- * This is a gross hack, but uses only one test.
- *)
- fun areSmall (i: bigInt, i': bigInt) =
- 0w0 <> Word.andb (Prim.toWord i, Word.andb (Prim.toWord i', 0w1))
-
- (*
- * Return the number of `limbs' in a bigInt.
- * If arg is big, then |arg| is in [ 2^ (32 (x-1)), 2^ (32 x) )
- * 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
- else bigSize arg
+ structure BigWord = C_MPLimb
+ structure SmallInt = ObjptrInt
- val bytesPerWord = 0w4
- (*
- * Reserve heap space for a bignum bigInt with room for size + extra
- * `limbs'. The reason for splitting this up is that extra is intended
- * to be a constant, and so can be combined at compile time with the 0w4
- * below.
- *)
- fun reserve (size: smallInt, extra: smallInt): word =
- Word.* (bytesPerWord,
- Word.+ (Word.fromInt size,
- Word.+ (0w4, (* counter, size, header, sign words *)
- Word.fromInt extra)))
+ structure W = ObjptrWord
+ structure I = ObjptrInt
+ structure MPLimb = C_MPLimb
- (*
- * Given a fixnum bigInt, return the Word.word which it
- * represents.
- * NOTE: it is an ERROR to call stripTag on an argument
- * which is a bignum bigInt.
- *)
- fun stripTag (arg: bigInt): Word.word =
- Word.~>> (Prim.toWord arg, 0w1)
+ val precision: Int.int option = NONE
- (*
- * Given a Word.word, add the tag bit in so that it looks like
- * a fixnum bigInt.
- *)
- fun addTag (argw: Word.word): Word.word =
- Word.orb (Word.<< (argw, 0w1), 0w1)
+ fun sign (arg: int): Int.int =
+ if Prim.isSmall arg
+ then I.sign (Prim.dropTagCoerceInt arg)
+ else if isNeg arg
+ then ~1
+ else 1
- (*
- * badw is the fixnum bigInt (as a word) whose negation and
- * absolute value are not fixnums. badv is the same thing
- * with the tag stripped off.
- * negBad is the negation (and absolute value) of that bigInt.
- *)
- val badw: Word.word = 0wx80000001 (* = Prim.toWord ~0x40000000 *)
- val badv: Word.word = 0wxC0000000 (* = stripTag ~0x40000000 *)
- val negBad: bigInt = bigIntConstant 0x40000000
+ fun sameSign (x, y) = sign x = sign y
- (*
- * Given two Word.word's, check if they have the same `sign' bit.
- *)
- fun sameSign (lhs: Word.word, rhs: Word.word): bool =
- Word.toIntX (Word.xorb (lhs, rhs)) >= 0
-
- (*
- * Given a bignum bigint, test if it is (strictly) negative.
- * Note: it is an ERROR to call bigIsNeg on an argument
- * which is a fixnum bigInt.
- *)
- fun bigIsNeg (arg: bigInt): bool =
- Primitive.Vector.sub (Prim.toVector arg, 0) <> 0w0
-
- (*
- * Convert a smallInt to a bigInt.
- *)
- fun bigFromInt (arg: smallInt): bigInt =
- let
- val argv = Word.fromInt arg
- val ans = addTag argv
- in
- if sameSign (argv, ans)
- then Prim.fromWord ans
- else let val space = Primitive.Array.array 2
- val (isneg, abs) = if arg < 0
- then (0w1, Word.- (0w0, argv))
- else (0w0, argv)
- val _ = Primitive.Array.update (space, 0, isneg)
- val _ = Primitive.Array.update (space, 1, abs)
- val space = Primitive.Vector.fromArray space
- in
- Prim.fromVector space
- end
- end
-
- fun rep x =
- if isSmall x
- then Small (Word.toIntX (stripTag x))
- else Big (Prim.toVector x)
-
- (*
- * Convert a bigInt to a smallInt, raising overflow if it
- * is too big.
- *)
- fun bigToInt (arg: bigInt): smallInt =
- if isSmall arg
- then Word.toIntX (stripTag arg)
- else if bigSize arg <> 1
- then raise Overflow
- else let val arga = Prim.toVector arg
- val argw = Primitive.Vector.sub (arga, 1)
- in if Primitive.Vector.sub (arga, 0) <> 0w0
- then if Word.<= (argw, 0wx80000000)
- then Word.toIntX (Word.- (0w0, argw))
- else raise Overflow
- else if Word.< (argw, 0wx80000000)
- then Word.toIntX argw
- else raise Overflow
- end
-
- fun bigFromInt64 (i: Int64.int): bigInt =
- if Int64.<= (~0x40000000, i) andalso Int64.<= (i, 0x3FFFFFFF)
- then Prim.fromWord (addTag (Word.fromInt (Int64.toInt i)))
- else
+ local
+ val maxShift32 = 0w128
+ val maxShift = Word32.toWord maxShift32
+ fun make f (arg, shift) =
let
- fun doit (i: Int64.int, isNeg): bigInt =
- if Int64.<= (i, 0xFFFFFFFF)
- then
- let
- val a = Primitive.Array.array 2
- val _ = Array.update (a, 0, isNeg)
- val _ = Array.update (a, 1, Int64.toWord i)
- in
- Prim.fromVector (Vector.fromArray a)
- end
- else
- let
- val a = Primitive.Array.array 3
- val _ = Array.update (a, 0, isNeg)
- val r = Int64.rem (i, 0x100000000)
- val _ = Array.update (a, 1, Int64.toWord r)
- val q = Int64.quot (i, 0x100000000)
- val _ = Array.update (a, 2, Int64.toWord q)
- in
- Prim.fromVector (Vector.fromArray a)
- end
+ fun loop (arg, shift) =
+ if Word.<= (shift, maxShift)
+ then f (arg, Word32.fromWord shift)
+ else loop (f (arg, maxShift32),
+ Word.- (shift, maxShift))
in
- if Int64.>= (i, 0)
- then doit (i, 0w0)
- else
- if i = valOf Int64.minInt
- then ~0x8000000000000000
- else doit (Int64.~? i, 0w1)
+ loop (arg, shift)
end
-
- fun bigToInt64 (arg: bigInt): Int64.int =
- case rep arg of
- Small i => Int64.fromInt i
- | Big v =>
- if Vector.length v > 3
- then raise Overflow
- else let
- val sign = Primitive.Vector.sub (v, 0)
- val w1 = Primitive.Vector.sub (v, 1)
- val w2 = Primitive.Vector.sub (v, 2)
- in
- if Word.> (w2, 0wx80000000)
- then raise Overflow
- else if w2 = 0wx80000000
- then if w1 = 0w0 andalso sign = 0w1
- then valOf Int64.minInt
- else raise Overflow
- else
- let
- val n =
- Int64.+?
- (Primitive.Int64.fromWord w1,
- Int64.*? (Primitive.Int64.fromWord w2,
- 0x100000000))
- in
- if sign = 0w1
- then Int64.~ n
- else n
- end
- end
-
- (*
- * bigInt negation.
- *)
- fun bigNegate (arg: bigInt): bigInt =
- if isSmall arg
- then let val argw = Prim.toWord arg
- in if argw = badw
- then negBad
- else Prim.fromWord (Word.- (0w2, argw))
- end
- else Prim.~ (arg, reserve (bigSize arg, 1))
-
- val dontInline: (unit -> 'a) -> 'a =
- fn f =>
- let
- val rec recur: int -> 'a =
- fn i =>
- if i = 0
- then f ()
- else (ignore (recur (i - 1))
- ; recur (i - 2))
- in
- recur 0
- end
-
-
- fun bigMul (lhs: bigInt, rhs: bigInt): bigInt =
- let
- val res =
- if areSmall (lhs, rhs)
- then let val ansv = (Word.fromInt o Int.*)
- (Word.toIntX (stripTag lhs),
- Word.toIntX (stripTag rhs))
- val ans = addTag ansv
- in
- if sameSign (ans, ansv)
- then SOME (Prim.fromWord ans)
- else NONE
- end handle Overflow => NONE
- else NONE
- in
- case res of
- NONE =>
- dontInline
- (fn () =>
- Prim.* (lhs, rhs, reserve (size lhs +? size rhs, 0)))
- | SOME i => i
- end
-
- (*
- * bigInt quot.
- * Round towards 0 (bigRem returns the remainder).
- * Note, if size num < size den, then the answer is 0.
- * The only non-trivial case here is num being - den,
- * and small, but in that case, although den may be big, its
- * size is still 1. (den cannot be 0 in this case.)
- * The space required for the shifted numerator limbs is <= nsize + 1.
- * The space required for the shifted denominator limbs is <= dsize
- * The space required for the quotient limbs is <= 1 + nsize - dsize.
- * Thus the total space for limbs is <= 2*nsize + 2 (and one extra
- * word for the isNeg flag).
- *)
- fun bigQuot (num: bigInt, den: bigInt): bigInt =
- if areSmall (num, den)
- then let val numv = stripTag num
- val denv = stripTag den
- in if numv = badv andalso denv = Word.fromInt ~1
- then negBad
- else let val numi = Word.toIntX numv
- val deni = Word.toIntX denv
- val ansi = Int.quot (numi, deni)
- val answ = Word.fromInt ansi
- in Prim.fromWord (addTag answ)
- end
- end
- else let val nsize = size num
- val dsize = size den
- in if nsize < dsize
- then zero
- else if den = zero
- then raise Div
- else
- Prim.quot
- (num, den,
- Word.* (Word.* (0w2, bytesPerWord),
- Word.+ (Word.fromInt nsize, 0w3)))
- end
-
- (*
- * bigInt rem.
- * Sign taken from numerator, quotient is returned by bigQuot.
- * Note, if size num < size den, then the answer is 0.
- * The only non-trivial case here is num being - den,
- * and small, but in that case, although den may be big, its
- * size is still 1. (den cannot be 0 in this case.)
- * The space required for the shifted numerator limbs is <= nsize + 1.
- * The space required for the shifted denominator limbs is <= dsize
- * The space required for the quotient limbs is <= 1 + nsize - dsize.
- * Thus the total space for limbs is <= 2*nsize + 2 (and one extra
- * word for the isNeg flag).
- *)
- fun bigRem (num: bigInt, den: bigInt): bigInt =
- if areSmall (num, den)
- then let val numv = stripTag num
- val numi = Word.toIntX numv
- val denv = stripTag den
- val deni = Word.toIntX denv
- val ansi = Int.rem (numi, deni)
- val answ = Word.fromInt ansi
- in Prim.fromWord (addTag answ)
- end
- else let val nsize = size num
- val dsize = size den
- in if nsize < dsize
- then num
- else if den = zero
- then raise Div
- else
- Prim.rem
- (num, den, Word.* (Word.* (0w2, bytesPerWord),
- Word.+ (Word.fromInt nsize, 0w3)))
- end
-
- (*
- * bigInt addition.
- *)
- fun bigPlus (lhs: bigInt, rhs: bigInt): bigInt =
- let
- val res =
- if areSmall (lhs, rhs)
- then let val ansv = Word.+ (stripTag lhs, stripTag rhs)
- val ans = addTag ansv
- in if sameSign (ans, ansv)
- then SOME (Prim.fromWord ans)
- else NONE
- end
- else NONE
- in
- case res of
- NONE =>
- dontInline
- (fn () =>
- Prim.+ (lhs, rhs, reserve (Int.max (size lhs, size rhs), 1)))
- | SOME i => i
- end
-
- (*
- * bigInt subtraction.
- *)
- fun bigMinus (lhs: bigInt, rhs: bigInt): bigInt =
- let
- val res =
- if areSmall (lhs, rhs)
- then
- let
- val ansv = Word.- (stripTag lhs, stripTag rhs)
- val ans = addTag ansv
- in
- if sameSign (ans, ansv)
- then SOME (Prim.fromWord ans)
- else NONE
- end
- else NONE
- in
- case res of
- NONE =>
- dontInline
- (fn () =>
- Prim.- (lhs, rhs, reserve (Int.max (size lhs, size rhs), 1)))
- | SOME i => i
- end
-
- (*
- * bigInt compare.
- *)
- fun bigCompare (lhs: bigInt, rhs: bigInt): order =
- if areSmall (lhs, rhs)
- then Int.compare (Word.toIntX (Prim.toWord lhs),
- Word.toIntX (Prim.toWord rhs))
- else Int.compare (Prim.compare (lhs, rhs), 0)
-
-
- (*
- * bigInt comparisions.
- *)
- local
- fun makeTest (smallTest: smallInt * smallInt -> bool)
- (lhs: bigInt, rhs: bigInt): bool =
- if areSmall (lhs, rhs)
- then smallTest (Word.toIntX (Prim.toWord lhs),
- Word.toIntX (Prim.toWord rhs))
- else smallTest (Prim.compare (lhs, rhs), 0)
in
- val bigGT = makeTest (op >)
- val bigGE = makeTest (op >=)
- val bigLE = makeTest (op <=)
- val bigLT = makeTest (op <)
+ val << = make <<
+ val ~>> = make ~>>
end
- (*
- * bigInt abs.
- *)
- fun bigAbs (arg: bigInt): bigInt =
- if isSmall arg
- then let val argw = Prim.toWord arg
- in if argw = badw
- then negBad
- else if Word.toIntX argw < 0
- then Prim.fromWord (Word.- (0w2, argw))
- else arg
- end
- else if bigIsNeg arg
- then Prim.~ (arg, reserve (bigSize arg, 1))
- else arg
-
- (*
- * bigInt min.
- *)
- fun bigMin (lhs: bigInt, rhs: bigInt): bigInt =
- if bigLE (lhs, rhs)
- then lhs
- else rhs
-
- (*
- * bigInt max.
- *)
- fun bigMax (lhs: bigInt, rhs: bigInt): bigInt =
- if bigLE (lhs, rhs)
- then rhs
- else lhs
-
- (*
- * bigInt sign.
- *)
- fun bigSign (arg: bigInt): smallInt =
- if isSmall arg
- then Int.sign (Word.toIntX (stripTag arg))
- else if bigIsNeg arg
- then ~1
- else 1
-
- (*
- * bigInt sameSign.
- *)
- fun bigSameSign (lhs: bigInt, rhs: bigInt): bool =
- bigSign lhs = bigSign rhs
-
- (*
- * bigInt gcd.
- * based on code from PolySpace.
- *)
local
- open Int
-
- fun mod2 x = Word.toIntX (Word.andb (Word.fromInt x, 0w1))
- fun div2 x = Word.toIntX (Word.>> (Word.fromInt x, 0w1))
-
- fun gcdInt (a, b, acc) =
- case (a, b) of
- (0, _) => b * acc
- | (_, 0) => a * acc
- | (_, 1) => acc
- | (1, _) => acc
- | _ =>
- if a = b
- then a * acc
- else
- let
- val a_2 = div2 a
- val a_r2 = mod2 a
- val b_2 = div2 b
- val b_r2 = mod2 b
- in
- if 0 = a_r2
- then
- if 0 = b_r2
- then gcdInt (a_2, b_2, acc + acc)
- else gcdInt (a_2, b, acc)
- else
- if 0 = b_r2
- then gcdInt (a, b_2, acc)
- else
- if a >= b
- then gcdInt (div2 (a - b), b, acc)
- else gcdInt (a, div2 (b - a), acc)
- end
-
- in
- fun bigGcd (lhs: bigInt, rhs: bigInt): bigInt =
- if areSmall (lhs, rhs)
- then
- Prim.fromWord
- (addTag
- (Word.fromInt
- (gcdInt (Int.abs (Word.toIntX (stripTag lhs)),
- Int.abs (Word.toIntX (stripTag rhs)),
- 1))))
- else Prim.gcd (lhs, rhs, reserve (max (size lhs, size rhs), 0))
- end
-
- (*
- * bigInt toString and fmt.
- * dpc is the maximum number of digits per `limb'.
- *)
- local
open StringCvt
- fun cvt {base: smallInt,
- dpc: word,
- smallCvt: smallInt -> string}
- (arg: bigInt)
- : string =
- if isSmall arg
- then smallCvt (Word.toIntX (stripTag arg))
- else Prim.toString (arg, base,
- Word.+
- (reserve (0, 0),
- Word.+ (0w2, (* sign character *)
- Word.* (dpc,
- Word.fromInt (bigSize arg)))))
- val binCvt = cvt {base = 2, dpc = 0w32, smallCvt = Int.fmt BIN}
- val octCvt = cvt {base = 8, dpc = 0w11, smallCvt = Int.fmt OCT}
- val hexCvt = cvt {base = 16, dpc = 0w8, smallCvt = Int.fmt HEX}
+ val binCvt = mkCvt {base = 2, smallCvt = I.fmt BIN}
+ val octCvt = mkCvt {base = 8, smallCvt = I.fmt OCT}
+ val decCvt = mkCvt {base = 10, smallCvt = I.fmt DEC}
+ val hexCvt = mkCvt {base = 16, smallCvt = I.fmt HEX}
in
- val bigToString = cvt {base = 10,
- dpc = 0w10,
- smallCvt = Int.toString}
- fun bigFmt radix =
+ fun fmt radix =
case radix of
BIN => binCvt
| OCT => octCvt
- | DEC => bigToString
+ | DEC => decCvt
| HEX => hexCvt
+ val toString = fmt DEC
end
- (*
- * bigInt scan and fromString.
- *)
local
open StringCvt
(*
- * We use Word.word to store chunks of digits.
- * smallToInf converts such a word to a fixnum bigInt.
- * Thus, it can only represent values in [- 2^30, 2^30).
- *)
- fun smallToBig (arg: Word.word): bigInt =
- Prim.fromWord (addTag arg)
-
-
- (*
* Given a char, if it is a digit in the appropriate base,
* convert it to a word. Otherwise, return NONE.
* Note, both a-f and A-F are accepted as hexadecimal digits.
*)
- fun binDig (ch: char): Word.word option =
+ fun binDig (ch: char): W.word option =
case ch of
#"0" => SOME 0w0
| #"1" => SOME 0w1
| _ => NONE
local
- val op <= = Char.<=
+ val op <= = PreChar.<=
in
- fun octDig (ch: char): Word.word option =
+ fun octDig (ch: char): W.word option =
if #"0" <= ch andalso ch <= #"7"
- then SOME (Word.fromInt (ord ch -? ord #"0"))
+ then SOME (W.fromInt (Int.- (PreChar.ord ch,
+ PreChar.ord #"0")))
else NONE
- fun decDig (ch: char): Word.word option =
+ fun decDig (ch: char): W.word option =
if #"0" <= ch andalso ch <= #"9"
- then SOME (Word.fromInt (ord ch -? ord #"0"))
+ then SOME (W.fromInt (Int.- (PreChar.ord ch,
+ PreChar.ord #"0")))
else NONE
- fun hexDig (ch: char): Word.word option =
+ fun hexDig (ch: char): W.word option =
if #"0" <= ch andalso ch <= #"9"
- then SOME (Word.fromInt (ord ch -? ord #"0"))
+ then SOME (W.fromInt (Int.- (PreChar.ord ch,
+ PreChar.ord #"0")))
else if #"a" <= ch andalso ch <= #"f"
- then SOME (Word.fromInt (ord ch -? (ord #"a" - 0xa)))
- else if #"A" <= ch andalso ch <= #"F"
- then SOME (Word.fromInt
- (ord ch -? (ord #"A" - 0xA)))
- else
- NONE
+ then SOME (W.fromInt (Int.- (PreChar.ord ch,
+ Int.- (PreChar.ord #"a", 0xa))))
+ else if #"A" <= ch andalso ch <= #"F"
+ then SOME (W.fromInt (Int.- (PreChar.ord ch,
+ Int.- (PreChar.ord #"A", 0xA))))
+ else NONE
end
(*
* Given a digit converter and a char reader, return a digit
* reader.
*)
- fun toDigR (charToDig: char -> Word.word option,
+ fun toDigR (charToDig: char -> W.word option,
cread: (char, 'a) reader)
- (s: 'a)
- : (Word.word * 'a) option =
+ (s: 'a)
+ : (W.word * 'a) option =
case cread s of
NONE => NONE
| SOME (ch, s') =>
@@ -640,87 +127,83 @@
* shift is base raised to the number-of-digits-seen power.
* chunk is the value of the digits seen.
*)
- type chunk = {
- more: bool,
- shift: Word.word,
- chunk: Word.word
- }
-
+ type chunk = {more: bool,
+ shift: W.word,
+ chunk: W.word}
(*
- * Given the base, the number of digits per chunk,
- * a char reader and a digit reader, return a chunk reader.
+ * Given the base and a digit reader,
+ * return a chunk reader.
*)
- fun toChunkR (base: Word.word,
- dpc: smallInt,
- dread: (Word.word, 'a) reader)
- : (chunk, 'a) reader =
- let fun loop {left: smallInt,
- shift: Word.word,
- chunk: Word.word,
- s: 'a}
- : chunk * 'a =
- if left <= 0
- then ({more = true,
- shift = shift,
- chunk = chunk },
- s)
- else
+ fun toChunkR (base: W.word,
+ dread: (W.word, 'a) reader)
+ : (chunk, 'a) reader =
+ let
+ fun loop {left: Int32.int,
+ shift: W.word,
+ chunk: W.word,
+ s: 'a}
+ : chunk * 'a =
+ if Int32.<= (left, 0)
+ then ({more = true,
+ shift = shift,
+ chunk = chunk},
+ s)
+ else
+ case dread s of
+ NONE => ({more = false,
+ shift = shift,
+ chunk = chunk},
+ s)
+ | SOME (dig, s') =>
+ loop {left = Int32.- (left, 1),
+ shift = W.* (base, shift),
+ chunk = W.+ (W.* (base, chunk), dig),
+ s = s'}
+ val digitsPerChunk =
+ Int32.quot (Int32.- (Int32.fromInt W.wordSize, 3), W.log2 base)
+ fun reader (s: 'a): (chunk * 'a) option =
case dread s of
- NONE => ({more = false,
- shift = shift,
- chunk = chunk},
- s)
- | SOME (dig, s') =>
- loop {
- left = left - 1,
- shift = Word.* (base, shift),
- chunk = Word.+ (Word.* (base,
- chunk),
- dig),
- s = s'
- }
- fun reader (s: 'a): (chunk * 'a) option =
- case dread s of
- NONE => NONE
- | SOME (dig, next) =>
- SOME (loop {left = dpc - 1,
- shift = base,
- chunk = dig,
- s = next})
- in reader
+ NONE => NONE
+ | SOME (dig, next) =>
+ SOME (loop {left = Int32.- (digitsPerChunk, 1),
+ shift = base,
+ chunk = dig,
+ s = next})
+ in
+ reader
end
(*
* Given a chunk reader, return an unsigned reader.
*)
- fun toUnsR (ckread: (chunk, 'a) reader): (bigInt, 'a) reader =
- let fun loop (more: bool, ac: bigInt, s: 'a) =
- if more
- then case ckread s of
- NONE => (ac, s)
- | SOME ({more, shift, chunk}, s') =>
- loop (more,
- bigPlus (bigMul (smallToBig shift,
- ac),
- smallToBig chunk),
- s')
- else (ac, s)
- fun reader (s: 'a): (bigInt * 'a) option =
- case ckread s of
- NONE => NONE
- | SOME ({more, chunk, ...}, s') =>
- SOME (loop (more,
- smallToBig chunk,
- s'))
- in reader
+ fun toUnsR (ckread: (chunk, 'a) reader): (int, 'a) reader =
+ let
+ fun loop (more: bool, acc: int, s: 'a) =
+ if more
+ then case ckread s of
+ NONE => (acc, s)
+ | SOME ({more, shift, chunk}, s') =>
+ loop (more,
+ ((Prim.addTagCoerce shift) * acc)
+ + (Prim.addTagCoerce chunk),
+ s')
+ else (acc, s)
+ fun reader (s: 'a): (int * 'a) option =
+ case ckread s of
+ NONE => NONE
+ | SOME ({more, chunk, ...}, s') =>
+ SOME (loop (more,
+ Prim.addTagCoerce chunk,
+ s'))
+ in
+ reader
end
(*
* Given a char reader and an unsigned reader, return an unsigned
* reader that includes skipping the option hex '0x'.
*)
- fun toHexR (cread: (char, 'a) reader, uread: (bigInt, 'a) reader)
- s =
+ fun toHexR (cread: (char, 'a) reader, uread: (int, 'a) reader) s =
case cread s of
NONE => NONE
| SOME (c1, s1) =>
@@ -732,77 +215,64 @@
case uread s2 of
NONE => SOME (zero, s1)
| SOME x => SOME x
- else uread s
- else uread s
+ else uread s
+ else uread s
(*
* Given a char reader and an unsigned reader, return a signed
* reader. This includes skipping any initial white space.
*)
- fun toSign (cread: (char, 'a) reader, uread: (bigInt, 'a) reader)
- : (bigInt, 'a) reader =
+ fun toSign (cread: (char, 'a) reader, uread: (int, 'a) reader)
+ : (int, 'a) reader =
let
- fun reader (s: 'a): (bigInt * 'a) option =
+ fun reader (s: 'a): (int * 'a) option =
case cread s of
NONE => NONE
| SOME (ch, s') =>
- if Char.isSpace ch then reader s'
- else
- let
- val (isNeg, s'') =
- case ch of
- #"+" => (false, s')
- | #"-" => (true, s')
- | #"~" => (true, s')
- | _ => (false, s)
- in
- if isNeg then
- case uread s'' of
- NONE => NONE
- | SOME (abs, s''') =>
- SOME (bigNegate abs, s''')
- else uread s''
- end
+ if PreChar.isSpace ch then reader s'
+ else let
+ val (isNeg, s'') =
+ case ch of
+ #"+" => (false, s')
+ | #"-" => (true, s')
+ | #"~" => (true, s')
+ | _ => (false, s)
+ in
+ if isNeg
+ then case uread s'' of
+ NONE => NONE
+ | SOME (abs, s''') => SOME (~ abs, s''')
+ else uread s''
+ end
in
reader
end
(*
* Base-specific conversions from char readers to
- * bigInt readers.
+ * int readers.
*)
local
- fun reader (base, dpc, dig)
- (cread: (char, 'a) reader): (bigInt, 'a) reader =
- let val dread = toDigR (dig, cread)
- val ckread = toChunkR (base, dpc, dread)
+ fun reader (base, dig)
+ (cread: (char, 'a) reader)
+ : (int, 'a) reader =
+ let
+ val dread = toDigR (dig, cread)
+ val ckread = toChunkR (base, dread)
val uread = toUnsR ckread
- val hread =
- if base = 0w16 then toHexR (cread, uread) else uread
+ val hread = if base = 0w16 then toHexR (cread, uread) else uread
val reader = toSign (cread, hread)
- in reader
+ in
+ reader
end
in
- fun binReader z = reader (0w2, 29, binDig) z
- fun octReader z = reader (0w8, 9, octDig) z
- fun decReader z = reader (0w10, 9, decDig) z
- fun hexReader z = reader (0w16, 7, hexDig) z
+ fun binReader z = reader (0w2, binDig) z
+ fun octReader z = reader (0w8, octDig) z
+ fun decReader z = reader (0w10, decDig) z
+ fun hexReader z = reader (0w16, hexDig) z
end
in
-
- local fun stringReader (pos, str) =
- if pos >= String.size str
- then NONE
- else SOME (String.sub (str, pos), (pos + 1, str))
- val reader = decReader stringReader
- in
- fun bigFromString str =
- case reader (0, str) of
- NONE => NONE
- | SOME (res, _) => SOME res
- end
-
- fun bigScan radix =
+ fun scan radix =
case radix of
BIN => binReader
| OCT => octReader
@@ -810,11 +280,13 @@
| HEX => hexReader
end
+ val fromString = StringCvt.scanString (scan StringCvt.DEC)
+
local
- fun isEven (n: int) = Int.mod (Int.abs n, 2) = 0
+ fun isEven (n: Int.int) = Int.andb (n, 0x1) = 0
in
- fun pow (i: bigInt, j: int): bigInt =
- if j < 0 then
+ fun pow (i: int, j: Int.int): int =
+ if Int.< (j, 0) then
if i = zero then
raise Div
else
@@ -825,188 +297,26 @@
if j = 0 then one
else
let
- fun square (n: bigInt): bigInt = bigMul (n, n)
+ fun square (n: int): int = n * n
(* pow (j) returns (i ^ j) *)
- fun pow (j: int): bigInt =
- if j <= 0 then one
+ fun pow (j: Int.int): int =
+ if Int.<= (j, 0) then one
else if isEven j then evenPow j
- else bigMul (i, evenPow (j - 1))
+ else i * evenPow (Int.- (j, 1))
(* evenPow (j) returns (i ^ j), assuming j is even *)
- and evenPow (j: int): bigInt =
- square (pow (Int.quot (j, 2)))
- in pow (j)
+ and evenPow (j: Int.int): int =
+ square (pow (Int.~>> (j, 0w1)))
+ in
+ pow j
end
end
- val op + = bigPlus
- val op - = bigMinus
- val op > = bigGT
- val op >= = bigGE
- val op < = bigLT
- val quot = bigQuot
- val rem = bigRem
+ val log2 =
+ mkLog2 {fromSmall = fn {smallLog2} => Int32.toInt smallLog2,
+ fromLarge = fn {numLimbsMinusOne, mostSigLimbLog2} =>
+ Int.+ (Int.* (MPLimb.wordSize, SeqIndex.toInt numLimbsMinusOne),
+ Int32.toInt mostSigLimbLog2)}
- fun x div y =
- if x >= zero
- then if y > zero
- then quot (x, y)
- else if y < zero
- then if x = zero
- then zero
- else quot (x - one, y) - one
- else raise Div
- else if y < zero
- then quot (x, y)
- else if y > zero
- then quot (x + one, y) - one
- else raise Div
-
- fun x mod y =
- if x >= zero
- then if y > zero
- then rem (x, y)
- else if y < zero
- then if x = zero
- then zero
- else rem (x - one, y) + (one + y)
- else raise Div
- else if y < zero
- then rem (x, y)
- else if y > zero
- then rem (x + one, y) + (y - one)
- else raise Div
-
- fun divMod (x, y) = (x div y, x mod y)
- fun quotRem (x, y) = (quot (x, y), rem (x, y))
-
- (*
- * bigInt log2
- *)
- structure Word =
- struct
- open Word
- fun log2 (w: word): int =
- let
- fun loop (n, s, ac): word =
- if n = 0w1
- then ac
- else
- let
- val (n, ac) =
- if n >= << (0w1, s)
- then (>> (n, s), ac + s)
- else (n, ac)
- in
- loop (n, >> (s, 0w1), ac)
- end
- in
- toInt (loop (w, 0w16, 0w0))
- end
- end
-
- local
- val bitsPerLimb: Int.int = 32
- in
- fun log2 (n: bigInt): Int.int =
- if bigLE (n, 0)
- then raise Domain
- else
- case rep n of
- Big v =>
- Int.+ (Int.* (bitsPerLimb, Int.- (Vector.length v, 2)),
- Word.log2 (Vector.sub (v, Int.- (Vector.length v, 1))))
- | Small i => Word.log2 (Word.fromInt i)
- end
-
- (*
- * bigInt bit operations.
- *)
- local
- fun make (wordOp, bigIntOp): bigInt * bigInt -> bigInt =
- 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
- dontInline
- (fn () =>
- bigIntOp (lhs, rhs, reserve (Int.max (size lhs, size rhs), 0)))
- in
- val bigAndb = make (Word.andb, Prim.andb)
- val bigOrb = make (Word.orb, Prim.orb)
- val bigXorb = make (Word.xorb, Prim.xorb)
- end
-
- fun bigNotb (arg: bigInt): bigInt =
- if isSmall arg
- then Prim.fromWord (addTag (Word.notb (stripTag arg)))
- else dontInline (fn () => Prim.notb (arg, reserve (size arg, 0)))
-
- local
- val bitsPerLimb : Word.word = 0w32
- fun shiftSize shift = Word.toIntX (Word.div (shift, bitsPerLimb))
- in
- fun bigArshift (arg: bigInt, shift: word): bigInt =
- if shift = 0wx0
- then arg
- else Prim.~>> (arg, shift,
- reserve (Int.max (1, size arg -? shiftSize shift),
- 0))
-
- fun bigLshift (arg: bigInt, shift: word): bigInt =
- if shift = 0wx0
- then arg
- else Prim.<< (arg, shift, reserve (size arg +? shiftSize shift, 1))
- end
-
- type int = bigInt
- val abs = bigAbs
- val compare = bigCompare
- val divMod = divMod
- val fmt = bigFmt
- val fromInt = bigFromInt
- val fromInt64 = bigFromInt64
- val fromLarge = fn x => x
- val fromString = bigFromString
- val gcd = bigGcd
- val max = bigMax
- val maxInt = NONE
- val min = bigMin
- val minInt = NONE
- val op * = bigMul
- val op + = bigPlus
- val op - = bigMinus
- val op < = bigLT
- val op <= = bigLE
- val op > = bigGT
- val op >= = bigGE
- val op div = op div
- val op mod = op mod
- val pow = pow
- val precision = NONE
- val quot = bigQuot
- val quotRem = quotRem
- val rem = bigRem
- val rep = rep
- val sameSign = bigSameSign
- val scan = bigScan
- val sign = bigSign
- val toInt = bigToInt
- val toInt64 = bigToInt64
- 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
+ val isSmall = Prim.isSmall
+ val areSmall = Prim.areSmall
end
-
-structure LargeInt = IntInf
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int-inf0.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/int-inf0.sml)
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int-inf1.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/int-inf1.sml)
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -6,88 +6,19 @@
* See the file MLton-LICENSE for details.
*)
-functor Integer (I: PRE_INTEGER_EXTRA) =
+functor Integer (I: PRE_INTEGER_EXTRA): INTEGER_EXTRA =
struct
open I
-structure PI = Primitive.Int
+type t = int
-val detectOverflow = Primitive.detectOverflow
-
-val (toInt, fromInt) =
- if detectOverflow andalso
- precision' <> PI.precision'
- then if PI.<(precision', PI.precision')
- then (I.toInt,
- fn i =>
- if (PI.<= (I.toInt minInt', i)
- andalso PI.<= (i, I.toInt maxInt'))
- then I.fromInt i
- else raise Overflow)
- else (fn i =>
- if (I.<= (I.fromInt PI.minInt', i)
- andalso I.<= (i, I.fromInt PI.maxInt'))
- then I.toInt i
- else raise Overflow,
- I.fromInt)
- else (I.toInt, I.fromInt)
-
+val precision': Int.int = Primitive.Int32.toInt precision'
val precision: Int.int option = SOME precision'
+val precisionWord': Word.word = Primitive.Word32.toWord precisionWord'
val maxInt: int option = SOME maxInt'
val minInt: int option = SOME minInt'
-val one: int = fromInt 1
-val zero: int = fromInt 0
-
-fun quot (x, y) =
- if y = zero
- then raise Div
- else if detectOverflow andalso x = minInt' andalso y = ~one
- then raise Overflow
- else I.quot (x, y)
-
-fun rem (x, y) =
- if y = zero
- then raise Div
- else if x = minInt' andalso y = ~one
- then zero
- else I.rem (x, y)
-
-fun x div y =
- if x >= zero
- then if y > zero
- then I.quot (x, y)
- else if y < zero
- then if x = zero
- then zero
- else I.quot (x - one, y) -? one
- else raise Div
- else if y < zero
- then if detectOverflow andalso x = minInt' andalso y = ~one
- then raise Overflow
- else I.quot (x, y)
- else if y > zero
- then I.quot (x + one, y) -? one
- else raise Div
-
-fun x mod y =
- if x >= zero
- then if y > zero
- then I.rem (x, y)
- else if y < zero
- then if x = zero
- then zero
- else I.rem (x - one, y) +? (y + one)
- else raise Div
- else if y < zero
- then if x = minInt' andalso y = ~one
- then zero
- else I.rem (x, y)
- else if y > zero
- then I.rem (x + one, y) +? (y - one)
- else raise Div
-
val sign: int -> Int.int =
fn i => if i = zero
then (0: Int.int)
@@ -96,11 +27,22 @@
else (1: Int.int)
fun sameSign (x, y) = sign x = sign y
-
-fun abs (x: int) = if x < zero then ~ x else x
-val {compare, min, max} = Util.makeCompare (op <)
-
+fun << (i, n) =
+ if Word.>= (n, precisionWord')
+ then zero
+ else I.<< (i, Primitive.Word32.fromWord n)
+fun >> (i, n) =
+ if Word.>= (n, precisionWord')
+ then zero
+ else I.>> (i, Primitive.Word32.fromWord n)
+fun ~>> (i, n) =
+ if Word.< (n, precisionWord')
+ then I.~>> (i, Primitive.Word32.fromWord n)
+ else I.~>> (i, Primitive.Word32.- (I.precisionWord', 0w1))
+fun rol (i, n) = I.rol (i, Primitive.Word32.fromWord n)
+fun ror (i, n) = I.ror (i, Primitive.Word32.fromWord n)
+
(* fmt constructs a string to represent the integer by building it into a
* statically allocated buffer. For the most part, this is a textbook
* algorithm: loop starting at the end of the buffer; we use rem to
@@ -118,43 +60,43 @@
(* Allocate a buffer large enough to hold any formatted integer in any radix.
* The most that will be required is for minInt in binary.
*)
- val maxNumDigits = PI.+ (precision', 1)
- val one = One.make (fn () => CharArray.array (maxNumDigits, #"\000"))
+ val maxNumDigits = Int.+ (precision', 1)
+ val oneBuf = One.make (fn () => CharArray.array (maxNumDigits, #"\000"))
in
fun fmt radix (n: int): string =
One.use
- (one, fn buf =>
- let
- val radix = fromInt (StringCvt.radixToInt radix)
- fun loop (q, i: Int.int) =
- let
- val _ =
- CharArray.update
- (buf, i, StringCvt.digitToChar (toInt (~? (rem (q, radix)))))
- val q = quot (q, radix)
- in
- if q = zero
- then
- let
- val start =
- if n < zero
- then
- let
- val i = PI.- (i, 1)
- val () = CharArray.update (buf, i, #"~")
- in
- i
- end
- else i
- in
- CharArraySlice.vector
- (CharArraySlice.slice (buf, start, NONE))
- end
- else loop (q, PI.- (i, 1))
- end
- in
- loop (if n < zero then n else ~? n, PI.- (maxNumDigits, 1))
- end)
+ (oneBuf, fn buf =>
+ let
+ val radix = fromInt (StringCvt.radixToInt radix)
+ fun loop (q, i: Int.int) =
+ let
+ val _ =
+ CharArray.update
+ (buf, i, StringCvt.digitToChar (toInt (~? (rem (q, radix)))))
+ val q = quot (q, radix)
+ in
+ if q = zero
+ then
+ let
+ val start =
+ if n < zero
+ then
+ let
+ val i = Int.- (i, 1)
+ val () = CharArray.update (buf, i, #"~")
+ in
+ i
+ end
+ else i
+ in
+ CharArraySlice.vector
+ (CharArraySlice.slice (buf, start, NONE))
+ end
+ else loop (q, Int.- (i, 1))
+ end
+ in
+ loop (if n < zero then n else ~? n, Int.- (maxNumDigits, 1))
+ end)
end
val toString = fmt StringCvt.DEC
@@ -214,34 +156,9 @@
val fromString = StringCvt.scanString (scan StringCvt.DEC)
-fun power {base, exp} =
- if Primitive.safe andalso exp < zero
- then raise Fail "Int.power"
- else let
- fun loop (exp, accum) =
- if exp <= zero
- then accum
- else loop (exp - one, base * accum)
- in loop (exp, one)
- end
end
structure Int8 = Integer (Primitive.Int8)
-
structure Int16 = Integer (Primitive.Int16)
-
structure Int32 = Integer (Primitive.Int32)
-structure Int = Int32
-structure IntGlobal: INTEGER_GLOBAL = Int
-open IntGlobal
-
-structure Int64 =
- struct
- local
- structure P = Primitive.Int64
- structure I = Integer (P)
- in
- open I
- val toWord = P.toWord
- end
- end
+structure Int64 = Integer (Primitive.Int64)
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int0.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/int0.sml)
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int1.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/int1.sml)
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/integer/integer.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/integer/integer.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/integer/integer.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -1,13 +1,3 @@
-structure Int =
- struct
- type int = int
- end
-
-structure LargeInt =
- struct
- type int = Primitive.IntInf.int
- end
-
signature INTEGER_GLOBAL =
sig
eqtype int
@@ -17,76 +7,117 @@
sig
include INTEGER_GLOBAL
+ val toLarge: int -> LargeInt.int
+ val fromLarge: LargeInt.int -> int
+ val toInt: int -> Int.int
+ val fromInt: Int.int -> int
+
+ val minInt: int option
+ val maxInt: int option
+
+ val + : int * int -> int
+ val - : int * int -> int
val * : int * int -> int
- val + : int * int -> int
- val - : int * int -> int
+ val div: int * int -> int
+ val mod: int * int -> int
+ val quot: int * int -> int
+ val rem: int * int -> int
+
+ val compare: int * int -> order
val < : int * int -> bool
val <= : int * int -> bool
val > : int * int -> bool
val >= : int * int -> bool
- val fromInt : Int.int -> int
- val quot : int * int -> int
- val rem : int * int -> int
- val toInt : int -> Int.int
+
val ~ : int -> int
+ val abs: int -> int
+ val min: int * int -> int
+ val max: int * int -> int
end
signature PRE_INTEGER_EXTRA =
sig
include PRE_INTEGER
- val << : int * Word.word -> int
- val >> : int * Word.word -> int
- val ~>> : int * Word.word -> int
+ val zero: int
+ val one: int
+
+ val precision' : Primitive.Int32.int
+ val precisionWord' : Primitive.Word32.word
+
+ val maxInt' : int
+ val minInt' : int
+
val *? : int * int -> int
val +? : int * int -> int
val -? : int * int -> int
- val andb : int * int -> int
- val maxInt' : int
- val minInt' : int
- val precision' : Int.int
val ~? : int -> int
+ val power: {base: int, exp: int} -> int
+
+ val andb: int * int -> int
+ val << : int * Primitive.Word32.word -> int
+ val notb: int -> int
+ val orb: int * int -> int
+ val rol: int * Primitive.Word32.word -> int
+ val ror: int * Primitive.Word32.word -> int
+ val ~>> : int * Primitive.Word32.word -> int
+ val >> : int * Primitive.Word32.word -> int
+ val xorb: int * int -> int
+
+ val ltu: int * int -> bool
+ val leu: int * int -> bool
+ val gtu: int * int -> bool
+ val geu: int * int -> bool
+
+ val fromSysWord: SysWord.word -> int
+ val toSysWord: int -> SysWord.word
end
signature INTEGER =
sig
include PRE_INTEGER
- val abs: int -> int
- val compare: int * int -> order
- val div: int * int -> int
- val fmt: StringCvt.radix -> int -> string
- 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 sameSign: int * int -> bool
- val scan: (StringCvt.radix
- -> (char, 'a) StringCvt.reader
+ val precision: Int.int option
+ val sign: int -> Int.int
+ val sameSign: int * int -> bool
+
+ val fmt: StringCvt.radix -> int -> string
+ val toString: int -> string
+ val scan: (StringCvt.radix
+ -> (char, 'a) StringCvt.reader
-> (int, 'a) StringCvt.reader)
- val sign: int -> Int.int
- val toLarge: int -> LargeInt.int
- val toString: int -> string
+ val fromString: string -> int option
end
signature INTEGER_EXTRA =
sig
include INTEGER
+ type t = int
- val << : int * Word.word -> int
- val >> : int * Word.word -> int
- val ~>> : int * Word.word -> int
+ val precision' : Int.int
+ val maxInt' : int
+ val minInt' : int
+
+ val +? : int * int -> int
val *? : int * int -> int
- val +? : int * int -> int
val -? : int * int -> int
val ~? : int -> int
- val andb : int * int -> int
- val maxInt' : int
- val minInt' : int
- val power: {base: int, exp: int} -> int
- val precision' : Int.int
+
+ val andb: int * int -> int
+ val << : int * Word.word -> int
+ val notb: int -> int
+ val orb: int * int -> int
+ val rol: int * Word.word -> int
+ val ror: int * Word.word -> int
+ val ~>> : int * Word.word -> int
+ val >> : int * Word.word -> int
+ val xorb: int * int -> int
+
+ val ltu: int * int -> bool
+ val leu: int * int -> bool
+ val gtu: int * int -> bool
+ val geu: int * int -> bool
+
+ val fromSysWord: SysWord.word -> int
+ val toSysWord: int -> SysWord.word
end
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/integer/pack-word.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/pack-word.sml)
Deleted: mlton/branches/on-20050822-x86_64-branch/basis-library/integer/pack-word32.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/integer/pack-word32.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/integer/pack-word32.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -1,66 +0,0 @@
-(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
- * Jagannathan, and Stephen Weeks.
- * Copyright (C) 1997-2000 NEC Research Institute.
- *
- * MLton is released under a BSD-style license.
- * See the file MLton-LICENSE for details.
- *)
-
-functor PackWord32 (val isBigEndian: bool): PACK_WORD =
-struct
-
-val bytesPerElem: int = 4
-
-val isBigEndian = isBigEndian
-
-val (sub, up, subV) =
- if isBigEndian = Primitive.MLton.Platform.Arch.hostIsBigEndian
- then (Primitive.Word8Array.subWord,
- Primitive.Word8Array.updateWord,
- Primitive.Word8Vector.subWord)
- else (Primitive.Word8Array.subWordRev,
- Primitive.Word8Array.updateWordRev,
- Primitive.Word8Vector.subWordRev)
-
-fun offset (i, n) =
- let
- val i = Int.* (bytesPerElem, i)
- val () =
- if Primitive.safe
- andalso (Primitive.Int.geu
- (Int.+ (i, Int.- (bytesPerElem, 1)), n)) then
- raise Subscript
- else
- ()
- in
- i
- end handle Overflow => raise Subscript
-
-local
- fun make (sub, length, toPoly) (av, i) =
- let
- val _ = offset (i, length av)
- in
- Word.toLarge (sub (toPoly av, i))
- end
-in
- val subArr = make (sub, Word8Array.length, Word8Array.toPoly)
- val subArrX = subArr
- val subVec = make (subV, Word8Vector.length, Word8Vector.toPoly)
- val subVecX = subVec
-end
-
-fun update (a, i, w) =
- let
- val a = Word8Array.toPoly a
- val _ = offset (i, Array.length a)
- in
- up (a, i, Word.fromLarge w)
- end
-
-end
-
-structure PackWord32Big = PackWord32 (val isBigEndian = true)
-structure PackWord32Little = PackWord32 (val isBigEndian = false)
-structure PackWord32Host =
- PackWord32(val isBigEndian = Primitive.MLton.Platform.Arch.hostIsBigEndian)
Deleted: mlton/branches/on-20050822-x86_64-branch/basis-library/integer/patch.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/integer/patch.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/integer/patch.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -1,147 +0,0 @@
-(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
- * Jagannathan, and Stephen Weeks.
- * Copyright (C) 1997-2000 NEC Research Institute.
- *
- * MLton is released under a BSD-style license.
- * See the file MLton-LICENSE for details.
- *)
-
-(* Patch in fromLarge and toLarge now that IntInf is defined. *)
-
-structure Int8: INTEGER_EXTRA =
- struct
- open Int8
-
- val fromLarge = fromInt o IntInf.toInt
- val toLarge = IntInf.fromInt o toInt
- end
-
-structure Int16: INTEGER_EXTRA =
- struct
- open Int16
-
- val fromLarge = fromInt o IntInf.toInt
- val toLarge = IntInf.fromInt o toInt
- end
-
-structure Int32: INTEGER_EXTRA =
- struct
- open Int32
-
- val fromLarge = IntInf.toInt
- val toLarge = IntInf.fromInt
- end
-
-structure Int64: INTEGER_EXTRA =
- struct
- open Int64
-
- val fromLarge = IntInf.toInt64
- val toLarge = IntInf.fromInt64
-
- val op * =
- if Primitive.detectOverflow
- then fn (i, j) => fromLarge (IntInf.* (toLarge i, toLarge j))
- else op *?
-
- (* Must redefine scan because the Integer functor defines it in terms of
- * Int64.*, which wasn't defined yet.
- *)
- fun scan radix reader state =
- case IntInf.scan radix reader state of
- NONE => NONE
- | SOME (i, s) => SOME (fromLarge i, s)
-
- val fromString = StringCvt.scanString (scan StringCvt.DEC)
- end
-
-structure Int = Int32
-structure Position = Int64
-structure FixedInt = Int64
-
-structure Word8: WORD_EXTRA =
- struct
- open Word8
-
- val toLargeIntX = LargeInt.fromInt o toIntX
- val toLargeInt = LargeInt.fromInt o toInt
-
- fun fromLargeInt (i: LargeInt.int): word =
- fromInt (LargeInt.toInt (LargeInt.mod (i, 0x100)))
- end
-
-structure Word16: WORD_EXTRA =
- struct
- open Word16
-
- val toLargeIntX = LargeInt.fromInt o toIntX
- val toLargeInt = LargeInt.fromInt o toInt
-
- fun fromLargeInt (i: LargeInt.int): word =
- fromInt (LargeInt.toInt (LargeInt.mod (i, 0x10000)))
- end
-
-structure Word32: WORD32_EXTRA =
- struct
- open Word32
-
- val toLargeIntX = IntInf.fromInt o toIntX
-
- fun highBitSet w = w >= 0wx80000000
-
- fun toLargeInt (w: word): LargeInt.int =
- if highBitSet w
- then IntInf.+ (0x80000000, toLargeIntX (andb (w, 0wx7FFFFFFF)))
- else toLargeIntX w
-
- local
- val t32: LargeInt.int = 0x100000000
- val t31: LargeInt.int = 0x80000000
- in
- fun fromLargeInt (i: IntInf.int): word =
- fromInt
- (let
- open IntInf
- val low32 = i mod t32
- in
- toInt (if low32 >= t31
- then low32 - t32
- else low32)
- end)
- end
- end
-
-structure Word = Word32
-
-structure SysWord = Word32
-
-structure Word64: WORD =
- struct
- open Word64
-
- structure W = Word64
-
- val t32: LargeInt.int = 0x100000000
- val t64: LargeInt.int = 0x10000000000000000
-
- fun toLargeInt w =
- IntInf.+
- (Word32.toLargeInt (Word32.fromLarge w),
- IntInf.<< (Word32.toLargeInt (Word32.fromLarge (>> (w, 0w32))),
- 0w32))
-
- fun toLargeIntX w =
- if Word32.toLarge 0w0 = andb (w, << (Word32.toLarge 0w1, 0w63))
- then toLargeInt w
- else IntInf.- (toLargeInt w, t64)
-
- fun fromLargeInt (i: IntInf.int): word =
- let
- val (d, m) = IntInf.divMod (i, t32)
- in
- W.orb (W.<< (Word32.toLarge (Word32.fromLargeInt d), 0w32),
- Word32.toLarge (Word32.fromLargeInt m))
- end
- end
-
-structure LargeWord = Word64
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/integer/word-global.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/word-global.sml)
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/integer/word.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/integer/word.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/integer/word.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -1,13 +1,3 @@
-structure Word =
- struct
- type word = word
- end
-
-structure LargeWord =
- struct
- type word = Primitive.Word64.word
- end
-
signature WORD_GLOBAL =
sig
eqtype word
@@ -17,66 +7,101 @@
sig
include WORD_GLOBAL
- val * : word * word -> word
- val + : word * word -> word
- val - : word * word -> word
- 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 div: word * word -> word
- val fromInt: Int.int -> word
- val fromLarge: LargeWord.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 toLarge: word -> LargeWord.word
val toLargeX: word -> LargeWord.word
- val wordSize: int
- val xorb: word * word -> word
+ val toLargeWord: word -> LargeWord.word
+ val toLargeWordX: word -> LargeWord.word
+ val fromLarge: LargeWord.word -> word
+ val fromLargeWord: LargeWord.word -> word
+ val toLargeInt: word -> LargeInt.int
+ val toLargeIntX: word -> LargeInt.int
+ val fromLargeInt: LargeInt.int -> word
+ val toInt: word -> int
+ val toIntX: word -> int
+ val fromInt: int -> word
+
+ val andb: word * word -> word
+ val orb: word * word -> word
+ val xorb: word * word -> word
+ val notb: 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 compare: word * word -> order
+ val < : word * word -> bool
+ val <= : word * word -> bool
+ val > : word * word -> bool
+ val >= : word * word -> bool
+
val ~ : word -> word
- val ~>> : word * Word.word -> word
+ val min: word * word -> word
+ val max: word * word -> word
end
signature PRE_WORD_EXTRA =
sig
include PRE_WORD
+
+ val zero: word
+
+ val wordSize: Primitive.Int32.int
+ val wordSizeWord: Primitive.Word32.word
+
+ val fromWord: Word.word -> word
+ val fromWordX: Word.word -> word
+ val fromSysWord: SysWord.word -> word
+ val fromSysWordX: SysWord.word -> word
+ val toWord: word -> Word.word
+ val toWordX: word -> Word.word
+ val toSysWord: word -> SysWord.word
+ val toSysWordX: word -> SysWord.word
+
+ val << : word * Primitive.Word32.word -> word
+ val >> : word * Primitive.Word32.word -> word
+ val ~>> : word * Primitive.Word32.word -> word
+ val rol: word * Primitive.Word32.word -> word
+ val ror: word * Primitive.Word32.word -> word
+ val log2 : word -> Primitive.Int32.int
end
signature WORD =
sig
include PRE_WORD
+
+ val wordSize: Int.int
+
+ val << : word * Word.word -> word
+ val >> : word * Word.word -> word
+ val ~>> : word * Word.word -> word
- val compare: word * word -> order
- val fmt: StringCvt.radix -> word -> string
- val fromLargeInt: LargeInt.int -> word
- val fromLargeWord: LargeWord.word -> word
- val fromString: string -> word option
- val max: word * word -> word
- val min: word * word -> word
+ val fmt: StringCvt.radix -> word -> string
+ val toString: word -> string
val scan: (StringCvt.radix
-> (char, 'a) StringCvt.reader
-> (word, 'a) StringCvt.reader)
- val toLargeInt: word -> LargeInt.int
- val toLargeIntX: word -> LargeInt.int
- val toLargeWord: word -> LargeWord.word
- val toLargeWordX: word -> LargeWord.word
- val toString: word -> string
+ val fromString: string -> word option
end
signature WORD_EXTRA =
sig
include WORD
- (* include PRE_WORD_EXTRA *)
- end
+ type t = word
-signature WORD32_EXTRA =
- sig
- include WORD_EXTRA
+ val wordSizeWord: Word.word
-(* val toReal: word -> real *)
+ val fromWord: Word.word -> word
+ val fromWordX: Word.word -> word
+ val fromSysWord: SysWord.word -> word
+ val fromSysWordX: SysWord.word -> word
+ val toWord: word -> Word.word
+ val toWordX: word -> Word.word
+ val toSysWord: word -> SysWord.word
+ val toSysWordX: word -> SysWord.word
+
+ val rol: word * Word.word -> word
+ val ror: word * Word.word -> word
+ val log2 : word -> Primitive.Int32.int
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/integer/word.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/integer/word.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/integer/word.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -10,72 +10,62 @@
struct
open W
-structure PW = Primitive.Word
+type t = word
-val detectOverflow = Primitive.detectOverflow
+val wordSize: Int.int = Primitive.Int32.toInt wordSize
+val wordSizeWord: Word.word = Primitive.Word32.toWord wordSizeWord
-(* These are overriden in patch.sml after int-inf.sml has been defined. *)
-val toLargeInt: word -> LargeInt.int = fn _ => raise Fail "toLargeInt"
-val toLargeIntX: word -> LargeInt.int = fn _ => raise Fail "toLargeIntX"
-val fromLargeInt: LargeInt.int -> word = fn _ => raise Fail "fromLargeInt"
+fun << (w, n) =
+ if Word.>= (n, wordSizeWord)
+ then zero
+ else W.<< (w, Primitive.Word32.fromWord n)
+fun >> (w, n) =
+ if Word.>= (n, wordSizeWord)
+ then zero
+ else W.>> (w, Primitive.Word32.fromWord n)
+fun ~>> (w, n) =
+ if Word.< (n, wordSizeWord)
+ then W.~>> (w, Primitive.Word32.fromWord n)
+ else W.~>> (w, Primitive.Word32.- (W.wordSizeWord, 0w1))
+fun rol (w, n) = W.rol (w, Primitive.Word32.fromWord n)
+fun ror (w, n) = W.ror (w, Primitive.Word32.fromWord n)
-val wordSizeWord: Word.word = PW.fromInt wordSize
-val wordSizeMinusOneWord: Word.word = PW.fromInt (Int.-? (wordSize, 1))
-val zero: word = fromInt 0
-
-val toLargeWord = toLarge
-val toLargeWordX = toLargeX
-val fromLargeWord = fromLarge
-
-fun toInt w =
- if detectOverflow
- andalso Int.>= (wordSize, Int.precision')
- andalso w > fromInt Int.maxInt'
- then raise Overflow
- else W.toInt w
-
-fun toIntX w =
- if detectOverflow
- andalso Int.> (wordSize, Int.precision')
- andalso fromInt Int.maxInt' < w
- andalso w < fromInt Int.minInt'
- then raise Overflow
- else W.toIntX w
-
local
- fun make f (w, w') =
- if Primitive.safe andalso w' = zero
- then raise Div
- else f (w, w')
+ (* Allocate a buffer large enough to hold any formatted word in any radix.
+ * The most that will be required is for maxWord in binary.
+ *)
+ val maxNumDigits = wordSize
+ val oneBuf = One.make (fn () => CharArray.array (maxNumDigits, #"\000"))
in
- val op div = make (op div)
- val op mod = make (op mod)
+ fun fmt radix (w: word): string =
+ One.use
+ (oneBuf, fn buf =>
+ let
+ val radix = fromInt (StringCvt.radixToInt radix)
+ fun loop (q, i: Int.int) =
+ let
+ val _ =
+ CharArray.update
+ (buf, i, StringCvt.digitToChar (toInt (q mod radix)))
+ val q = q div radix
+ in
+ if q = zero
+ then CharArraySlice.vector
+ (CharArraySlice.slice (buf, i, NONE))
+ else loop (q, Int.- (i, 1))
+ end
+ in
+ loop (w, Int.- (maxNumDigits, 1))
+ end)
end
-fun << (i, n)
- = if PW.>=(n ,wordSizeWord)
- then zero
- else W.<<(i, n)
-
-fun >> (i, n)
- = if PW.>=(n, wordSizeWord)
- then zero
- else W.>>(i, n)
-
-fun ~>> (i, n)
- = if PW.<(n, wordSizeWord)
- then W.~>>(i, n)
- else W.~>>(i, wordSizeMinusOneWord)
-
-val {compare, min, max} = Util.makeCompare(op <)
-
fun fmt radix (w: word): string =
let val radix = fromInt (StringCvt.radixToInt radix)
fun loop (q, chars) =
let val chars = StringCvt.digitToChar (toInt (q mod radix)) :: chars
val q = q div radix
in if q = zero
- then String0.implode chars
+ then PreString.implode chars
else loop (q, chars)
end
in loop (w, [])
@@ -154,6 +144,3 @@
structure Word16 = Word (Primitive.Word16)
structure Word32 = Word (Primitive.Word32)
structure Word64 = Word (Primitive.Word64)
-structure Word = Word32
-structure WordGlobal: WORD_GLOBAL = Word
-open WordGlobal
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/integer/word0.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/word0.sml)
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/integer/word1.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/word1.sml)
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/io/bin-io.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/io/bin-io.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/io/bin-io.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -12,8 +12,8 @@
structure PrimIO = BinPrimIO
structure Vector = Word8Vector
structure VectorSlice = Word8VectorSlice
- val chunkSize = Primitive.TextIO.bufSize
- val fileTypeFlags = [SysWord.fromInt PrimitiveFFI.Posix.FileSys.O.BINARY]
+ val chunkSize = Int32.toInt (Primitive.Controls.bufSize)
+ val fileTypeFlags = [PrimitiveFFI.Posix.FileSys.O.BINARY]
val line = NONE
val mkReader = Posix.IO.mkBinReader
val mkWriter = Posix.IO.mkBinWriter
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/io/imperative-io.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/io/imperative-io.fun 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/io/imperative-io.fun 2006-05-06 18:44:35 UTC (rev 4468)
@@ -9,7 +9,7 @@
sig
structure Array: sig
include MONO_ARRAY
- val rawArray: int -> array
+ val arrayUninit: int -> array
val unsafeSub: array * int -> elem
end
structure ArraySlice: MONO_ARRAY_SLICE
@@ -218,7 +218,7 @@
local
val augmentedReader = PIO.nullRd ()
- val buf = A.rawArray 0
+ val buf = A.arrayUninit 0
val first = ref 0
val last = ref 0
val reader = PIO.nullRd ()
@@ -373,7 +373,7 @@
(ib, "inputN", fn () =>
let
val readArr = readArr ib
- val inp = A.rawArray n
+ val inp = A.arrayUninit n
fun fill k =
if k >= size
then ()
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/io/io.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/io/io.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/io/io.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -1,3 +1,11 @@
+(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+ * Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ *)
+
signature IO =
sig
exception Io of {name : string,
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/io/prim-io.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/io/prim-io.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/io/prim-io.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -1,3 +1,10 @@
+(* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh
+ * Jagannathan, and Stephen Weeks.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ *)
+
signature PRIM_IO =
sig
type elem
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/io/text-io.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/io/text-io.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/io/text-io.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -15,8 +15,8 @@
structure PrimIO = TextPrimIO
structure Vector = CharVector
structure VectorSlice = CharVectorSlice
- val chunkSize = Primitive.TextIO.bufSize
- val fileTypeFlags = [SysWord.fromInt PrimitiveFFI.Posix.FileSys.O.TEXT]
+ val chunkSize = Int32.toInt (Primitive.Controls.bufSize)
+ val fileTypeFlags = [PrimitiveFFI.Posix.FileSys.O.TEXT]
val line = SOME {isLine = fn c => c = #"\n",
lineElem = #"\n"}
val mkReader = Posix.IO.mkTextReader
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-2002/top-level/basis.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-2002/top-level/basis.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-2002/top-level/basis.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -328,29 +328,31 @@
(* Can't use sharing on type array or vector, because they are rigid tycons.
* Don't need it anyways, since it's built into the ARRAY and VECTOR signatures.
*)
-(* sharing type array = Array.array *)
-(* sharing type vector = Vector.vector *)
- (*
+(*
+ sharing type array = Array.array
+ sharing type vector = Vector.vector
+*)
+(*
sharing type ref = General.ref
- *)
- (*
+*)
+(*
sharing type bool = Bool.bool
- *)
+*)
sharing type option = Option.option
sharing type order = General.order
- (*
+(*
sharing type list = List.list
- *)
+*)
- sharing type int = Int32.int
- sharing type real = Real64.real
- sharing type word = Word32.word
-
(* Required structures *)
-(* sharing type BinIO.StreamIO.elem = Word8.word *)
+(*
+ sharing type BinIO.StreamIO.elem = Word8.word
+*)
sharing type BinIO.StreamIO.reader = BinPrimIO.reader
sharing type BinIO.StreamIO.pos = BinPrimIO.pos
-(* sharing type BinIO.StreamIO.vector = Word8Vector.vector *)
+(*
+ sharing type BinIO.StreamIO.vector = Word8Vector.vector
+*)
sharing type BinIO.StreamIO.writer = BinPrimIO.writer
sharing type BinPrimIO.array = Word8Array.array
sharing type BinPrimIO.array_slice = Word8ArraySlice.slice
@@ -387,15 +389,18 @@
sharing type Text.CharArray.array = CharArray.array
sharing type Text.CharArraySlice.slice = CharArraySlice.slice
sharing type Text.CharVectorSlice.slice = CharVectorSlice.slice
-(* redundant *)
-(* sharing type TextIO.elem = char *)
-(* sharing type TextIO.vector = string *)
+ (* redundant *)
+(*
+ sharing type TextIO.elem = char
+ sharing type TextIO.vector = string
+*)
sharing type TextPrimIO.array = CharArray.array
sharing type TextPrimIO.array_slice = CharArraySlice.slice
sharing type TextPrimIO.elem = Char.char
sharing type TextPrimIO.pos = Position.int
sharing type TextPrimIO.vector = CharVector.vector
sharing type TextPrimIO.vector_slice = CharVectorSlice.slice
+ sharing type Word.word = word
sharing type Word8Array.elem = Word8.word
sharing type Word8Array.vector = Word8Vector.vector
sharing type Word8ArraySlice.elem = Word8.word
@@ -450,7 +455,6 @@
sharing type Int16VectorSlice.vector = Int16Vector.vector
sharing type Int16Array2.elem = Int16.int
sharing type Int16Array2.vector = Int16Vector.vector
- sharing type Int32.int = Int.int
sharing type Int32Array.elem = Int32.int
sharing type Int32Array.vector = Int32Vector.vector
sharing type Int32ArraySlice.elem = Int32.int
@@ -574,7 +578,6 @@
sharing type Word16VectorSlice.vector = Word16Vector.vector
sharing type Word16Array2.elem = Word16.word
sharing type Word16Array2.vector = Word16Vector.vector
- sharing type Word32.word = Word.word
sharing type Word32Array.elem = Word32.word
sharing type Word32Array.vector = Word32Vector.vector
sharing type Word32ArraySlice.elem = Word32.word
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-extra/basis-extra.mlb
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-extra/basis-extra.mlb 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-extra/basis-extra.mlb 2006-05-06 18:44:35 UTC (rev 4468)
@@ -12,251 +12,8 @@
"warnUnused false" "forceUsed"
in
local
- ../../primitive/primitive.mlb
- (* Common basis implementation. *)
- ../../top-level/infixes.sml
- ../../misc/basic.sml
- ../../misc/dynamic-wind.sig
- ../../misc/dynamic-wind.sml
- ../../general/general.sig
- ../../general/general.sml
- ../../misc/one.sml
- ../../misc/util.sml
- ../../general/option.sig
- ../../general/option.sml
- ../../list/list.sig
- ../../list/list.sml
- ../../list/list-pair.sig
- ../../list/list-pair.sml
- ../../arrays-and-vectors/slice.sig
- ../../arrays-and-vectors/sequence.sig
- ../../arrays-and-vectors/sequence.fun
- ../../arrays-and-vectors/vector-slice.sig
- ../../arrays-and-vectors/vector.sig
- ../../arrays-and-vectors/vector.sml
- ../../arrays-and-vectors/array-slice.sig
- ../../arrays-and-vectors/array.sig
- ../../arrays-and-vectors/array.sml
- ../../arrays-and-vectors/array2.sig
- ../../arrays-and-vectors/array2.sml
- ../../arrays-and-vectors/mono-vector-slice.sig
- ../../arrays-and-vectors/mono-vector.sig
- ../../arrays-and-vectors/mono-vector.fun
- ../../arrays-and-vectors/mono-array-slice.sig
- ../../arrays-and-vectors/mono-array.sig
- ../../arrays-and-vectors/mono-array.fun
- ../../arrays-and-vectors/mono-array2.sig
- ../../arrays-and-vectors/mono-array2.fun
- ../../arrays-and-vectors/mono.sml
- ../../text/string0.sml
- ../../text/char0.sml
- ../../misc/reader.sig
- ../../misc/reader.sml
- ../../text/string-cvt.sig
- ../../text/string-cvt.sml
- ../../general/bool.sig
- ../../general/bool.sml
- ../../integer/integer.sig
- ../../integer/int.sml
- ../../text/char.sig
- ../../text/char.sml
- ../../text/substring.sig
- ../../text/substring.sml
- ../../text/string.sig
- ../../text/string.sml
- ../../misc/C.sig
- ../../misc/C.sml
- ../../integer/word.sig
- ../../integer/word.sml
- ../../integer/int-inf.sig
- ../../integer/int-inf.sml
- ../../real/IEEE-real.sig
- ../../real/IEEE-real.sml
- ../../real/math.sig
- ../../real/real.sig
- ../../real/real.fun
- ../../integer/pack-word.sig
- ../../integer/pack-word32.sml
- ../../text/byte.sig
- ../../text/byte.sml
- ../../text/text.sig
- ../../text/text.sml
- ../../real/pack-real.sig
- ../../real/pack-real.sml
- ../../real/real32.sml
- ../../real/real64.sml
- ../../integer/patch.sml
- ../../integer/embed-int.sml
- ../../integer/embed-word.sml
- ann "forceUsed" in
- ../../config/c/$(TARGET_ARCH)-$(TARGET_OS)/c-types.sml
- end
+ ../../build/sources.mlb
- ../../top-level/arithmetic.sml
-
- (* misc/unique-id.sig *)
- (* misc/unique-id.fun *)
- ../../misc/cleaner.sig
- ../../misc/cleaner.sml
-
- ../../system/pre-os.sml
- ../../system/time.sig
- ../../system/time.sml
- ../../system/date.sig
- ../../system/date.sml
-
- ../../io/io.sig
- ../../io/io.sml
- ../../io/prim-io.sig
- ../../io/prim-io.fun
- ../../io/bin-prim-io.sml
- ../../io/text-prim-io.sml
-
- ../../posix/error.sig
- ../../posix/error.sml
- ../../posix/stub-mingw.sml
- ../../posix/flags.sig
- ../../posix/flags.sml
- ../../posix/signal.sig
- ../../posix/signal.sml
- ../../posix/proc-env.sig
- ../../posix/proc-env.sml
- ../../posix/file-sys.sig
- ../../posix/file-sys.sml
- ../../posix/io.sig
- ../../posix/io.sml
- ../../posix/process.sig
- ../../posix/process.sml
- ../../posix/sys-db.sig
- ../../posix/sys-db.sml
- ../../posix/tty.sig
- ../../posix/tty.sml
- ../../posix/posix.sig
- ../../posix/posix.sml
-
- ../../platform/cygwin.sml
-
- ../../io/stream-io.sig
- ../../io/stream-io.fun
- ../../io/imperative-io.sig
- ../../io/imperative-io.fun
- ../../io/bin-stream-io.sig
- ../../io/bin-io.sig
- ../../io/bin-io.sml
- ../../io/text-stream-io.sig
- ../../io/text-io.sig
- ../../io/text-io.sml
-
- ../../system/path.sig
- ../../system/path.sml
- ../../system/file-sys.sig
- ../../system/file-sys.sml
- ../../system/command-line.sig
- ../../system/command-line.sml
-
- ../../general/sml90.sig
- ../../general/sml90.sml
-
- ../../mlton/pointer.sig
- ../../mlton/pointer.sml
- ../../mlton/call-stack.sig
- ../../mlton/call-stack.sml
- ../../mlton/exit.sml
- ../../mlton/exn.sig
- ../../mlton/exn.sml
- ../../mlton/thread.sig
- ../../mlton/thread.sml
- ../../mlton/signal.sig
- ../../mlton/signal.sml
- ../../mlton/process.sig
- ../../mlton/process.sml
- ../../mlton/gc.sig
- ../../mlton/gc.sml
- ../../mlton/rusage.sig
- ../../mlton/rusage.sml
-
- ../../system/process.sig
- ../../system/process.sml
- ../../system/io.sig
- ../../system/io.sml
- ../../system/os.sig
- ../../system/os.sml
- ../../system/unix.sig
- ../../system/unix.sml
- ../../system/timer.sig
- ../../system/timer.sml
-
- ../../net/net.sig
- ../../net/net.sml
- ../../net/net-host-db.sig
- ../../net/net-host-db.sml
- ../../net/net-prot-db.sig
- ../../net/net-prot-db.sml
- ../../net/net-serv-db.sig
- ../../net/net-serv-db.sml
- ../../net/socket.sig
- ../../net/socket.sml
- ../../net/generic-sock.sig
- ../../net/generic-sock.sml
- ../../net/inet-sock.sig
- ../../net/inet-sock.sml
- ../../net/unix-sock.sig
- ../../net/unix-sock.sml
-
- ../../mlton/array.sig
- ../../mlton/cont.sig
- ../../mlton/cont.sml
- ../../mlton/random.sig
- ../../mlton/random.sml
- ../../mlton/io.sig
- ../../mlton/io.fun
- ../../mlton/text-io.sig
- ../../mlton/bin-io.sig
- ../../mlton/itimer.sig
- ../../mlton/itimer.sml
- ../../mlton/ffi.sig
- ann
- "ffiStr MLtonFFI"
- in
- ../../mlton/ffi.sml
- end
- ../../mlton/int-inf.sig
- ../../mlton/platform.sig
- ../../mlton/platform.sml
- ../../mlton/proc-env.sig
- ../../mlton/proc-env.sml
- ../../mlton/profile.sig
- ../../mlton/profile.sml
- (*
- # mlton/ptrace.sig
- # mlton/ptrace.sml
- *)
- ../../mlton/rlimit.sig
- ../../mlton/rlimit.sml
- ../../mlton/socket.sig
- ../../mlton/socket.sml
- ../../mlton/syslog.sig
- ann
- "allowFFI true"
- in
- ../../mlton/syslog.sml
- end
- ../../mlton/vector.sig
- ../../mlton/weak.sig
- ../../mlton/weak.sml
- ../../mlton/finalizable.sig
- ../../mlton/finalizable.sml
- ../../mlton/word.sig
- ../../mlton/world.sig
- ../../mlton/world.sml
- ../../mlton/mlton.sig
- ../../mlton/mlton.sml
-
- ../../sml-nj/sml-nj.sig
- ../../sml-nj/sml-nj.sml
- ../../sml-nj/unsafe.sig
- ../../sml-nj/unsafe.sml
-
top-level/basis.sig
ann
"allowRebindEquals true"
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-extra/top-level/basis.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-extra/top-level/basis.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-extra/top-level/basis.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -362,10 +362,6 @@
sharing type list = List.list
*)
- sharing type int = Int32.int
- sharing type real = Real64.real
- sharing type word = Word32.word
-
(* Required structures *)
(*
sharing type BinIO.StreamIO.elem = Word8.word
@@ -411,7 +407,7 @@
sharing type Text.CharArray.array = CharArray.array
sharing type Text.CharArraySlice.slice = CharArraySlice.slice
sharing type Text.CharVectorSlice.slice = CharVectorSlice.slice
-(* redundant *)
+ (* redundant *)
(*
sharing type TextIO.elem = char
sharing type TextIO.vector = string
@@ -422,6 +418,7 @@
sharing type TextPrimIO.pos = Position.int
sharing type TextPrimIO.vector = CharVector.vector
sharing type TextPrimIO.vector_slice = CharVectorSlice.slice
+ sharing type Word.word = word
sharing type Word8Array.elem = Word8.word
sharing type Word8Array.vector = Word8Vector.vector
sharing type Word8ArraySlice.elem = Word8.word
@@ -476,7 +473,6 @@
sharing type Int16VectorSlice.vector = Int16Vector.vector
sharing type Int16Array2.elem = Int16.int
sharing type Int16Array2.vector = Int16Vector.vector
- sharing type Int32.int = Int.int
sharing type Int32Array.elem = Int32.int
sharing type Int32Array.vector = Int32Vector.vector
sharing type Int32ArraySlice.elem = Int32.int
@@ -600,7 +596,6 @@
sharing type Word16VectorSlice.vector = Word16Vector.vector
sharing type Word16Array2.elem = Word16.word
sharing type Word16Array2.vector = Word16Vector.vector
- sharing type Word32.word = Word.word
sharing type Word32Array.elem = Word32.word
sharing type Word32Array.vector = Word32Vector.vector
sharing type Word32ArraySlice.elem = Word32.word
@@ -645,11 +640,13 @@
where type 'a vector = 'a vector
where type char = char
where type exn = exn
+ where type int = int
where type order = order
where type real = real
where type string = string
where type substring = substring
where type unit = unit
+ where type word = word
(* Types referenced in signatures by structure name *)
(*
@@ -740,6 +737,7 @@
where type Int64.int = Int64.int
where type IntInf.int = IntInf.int
where type Real32.real = Real32.real
+ where type Real64.real = Real64.real
where type Word1.word = Word1.word
where type Word2.word = Word2.word
where type Word3.word = Word3.word
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-extra/top-level/basis.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-extra/top-level/basis.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-extra/top-level/basis.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -256,7 +256,6 @@
OptionGlobal
RealGlobal
StringGlobal
- RealGlobal
SubstringGlobal
TextIOGlobal
VectorGlobal
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/list/list.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/list/list.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/list/list.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -8,9 +8,9 @@
structure List: LIST =
struct
- open Primitive.Int
+ open Int
- datatype list = datatype list
+ datatype list = datatype Primitive.List.list
exception Empty
@@ -101,7 +101,7 @@
fun all pred = not o (exists (not o pred))
fun tabulate (n, f) =
- if Primitive.safe andalso n < 0
+ if Primitive.Controls.safe andalso n < 0
then raise Size
else let
fun loop (i, ac) =
@@ -121,7 +121,7 @@
then loop (l, n - 1)
else x
in
- if Primitive.safe andalso n < 0
+ if Primitive.Controls.safe andalso n < 0
then raise Subscript
else loop (l, n)
end
@@ -135,7 +135,7 @@
| x :: l => loop (l, n - 1, x :: ac))
else rev ac
in
- if Primitive.safe andalso n < 0
+ if Primitive.Controls.safe andalso n < 0
then raise Subscript
else loop (l, n, [])
end
@@ -149,7 +149,7 @@
| _ :: l => loop (l, n - 1))
else l
in
- if Primitive.safe andalso n < 0
+ if Primitive.Controls.safe andalso n < 0
then raise Subscript
else loop (l, n)
end
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/maps (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/maps)
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/call-stack.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/call-stack.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/call-stack.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -7,18 +7,18 @@
structure MLtonCallStack =
struct
- open Primitive.CallStack
+ open Primitive.MLton.CallStack
- val gcState = Primitive.GCState.gcState
+ val gcState = Primitive.MLton.GCState.gcState
structure Pointer = MLtonPointer
val current: unit -> t =
fn () =>
if not keep
- then T (Array.array (0, 0))
+ then T (Array.array (0, 0wx0))
else
let
- val a = Array.array (numStackFrames gcState, ~1)
+ val a = Array.arrayUninit (Word32.toInt (numStackFrames gcState))
val () = callStack (gcState, a)
in
T a
@@ -39,13 +39,12 @@
else
let
val p = frameIndexSourceSeq (gcState, frameIndex)
- val max = Pointer.getInt32 (p, 0)
+ val max = Int32.toInt (Pointer.getInt32 (p, 0))
fun loop (j, ac) =
if j > max
then ac
else loop (j + 1,
- COld.CS.toString (sourceName
- (gcState, Pointer.getInt32 (p, j)))
+ CUtil.C_String.toString (sourceName (gcState, Pointer.getWord32 (p, j)))
:: ac)
in
loop (1, ac)
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/cont.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/cont.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/cont.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -9,47 +9,55 @@
structure MLtonCont:> MLTON_CONT =
struct
-structure Thread = Primitive.Thread
-val gcState = Primitive.GCState.gcState
+structure Thread = Primitive.MLton.Thread
+fun die (s: string): 'a =
+ (PrimitiveFFI.Stdio.print s
+ ; PrimitiveFFI.Posix.Process.exit 1
+ ; let exception DieFailed
+ in raise DieFailed
+ end)
+
+val gcState = Primitive.MLton.GCState.gcState
+
type 'a t = (unit -> 'a) -> unit
fun callcc (f: 'a t -> 'a): 'a =
- if MLtonThread.amInSignalHandler () then
- die "callcc can not be used in a signal handler\n"
- else
- let
- datatype 'a state =
- Original of 'a t -> 'a
- | Copy of unit -> 'a
- | Clear
- val r: 'a state ref = ref (Original f)
- val _ = Thread.atomicBegin () (* Match 1 *)
- val _ = Thread.copyCurrent ()
- in
- case (!r before r := Clear) of
- Clear => raise Fail "callcc saw Clear"
- | Copy v => (Thread.atomicEnd () (* Match 2 *)
- ; v ())
- | Original f =>
- let
- val t = Thread.savedPre gcState
- in
- Thread.atomicEnd () (* Match 1 *)
- ; f (fn v =>
- let
- val _ = Thread.atomicBegin () (* Match 2 *)
- val _ = r := Copy v
- val new = Thread.copy t
- (* The following Thread.atomicBegin ()
- * is matched by Thread.switchTo.
- *)
- val _ = Thread.atomicBegin ()
- in
- Thread.switchTo new
- end)
- end
- end
+ if MLtonThread.amInSignalHandler ()
+ then die "callcc can not be used in a signal handler\n"
+ else
+ let
+ datatype 'a state =
+ Original of 'a t -> 'a
+ | Copy of unit -> 'a
+ | Clear
+ val r: 'a state ref = ref (Original f)
+ val _ = Thread.atomicBegin () (* Match 1 *)
+ val _ = Thread.copyCurrent ()
+ in
+ case (!r before r := Clear) of
+ Clear => raise Fail "callcc saw Clear"
+ | Copy v => (Thread.atomicEnd () (* Match 2 *)
+ ; v ())
+ | Original f =>
+ let
+ val t = Thread.savedPre gcState
+ in
+ Thread.atomicEnd () (* Match 1 *)
+ ; f (fn v =>
+ let
+ val _ = Thread.atomicBegin () (* Match 2 *)
+ val _ = r := Copy v
+ val new = Thread.copy t
+ (* The following Thread.atomicBegin ()
+ * is matched by Thread.switchTo.
+ *)
+ val _ = Thread.atomicBegin ()
+ in
+ Thread.switchTo new
+ end)
+ end
+ end
fun ('a, 'b) throw' (k: 'a t, v: unit -> 'a): 'b =
(k v; raise Fail "throw bug")
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/exit.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/exit.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/exit.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -33,7 +33,7 @@
in
if 0 <= i andalso i < 256
then (let open Cleaner in clean atExit end
- ; Primitive.halt status
+ ; Primitive.MLton.halt status
; raise Fail "exit")
else raise Fail (concat ["exit must have 0 <= status < 256: saw ",
Int.toString i])
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/exn.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/exn.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/exn.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -7,7 +7,7 @@
structure MLtonExn =
struct
- open Primitive.Exn
+ open Primitive.MLton.Exn
type t = exn
@@ -42,7 +42,7 @@
else fn _ => []
local
- val message = Primitive.Stdio.print
+ val message = PrimitiveFFI.Stdio.print
in
fun 'a topLevelHandler (exn: exn): 'a =
(message (concat ["unhandled exception: ", exnMessage exn, "\n"])
@@ -54,7 +54,7 @@
l)))
; Exit.exit Exit.Status.failure)
handle _ => (message "Toplevel handler raised exception.\n"
- ; Primitive.halt Exit.Status.failure
+ ; Primitive.MLton.halt Exit.Status.failure
(* The following raise is unreachable, but must be there
* so that the expression is of type 'a.
*)
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/ffi.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/ffi.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/ffi.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -11,8 +11,10 @@
val atomicEnd: unit -> unit
val getBool: int -> bool
val getChar8: int -> Char.char
+(*
val getChar16: int -> Char16.char
val getChar32: int -> Char32.char
+*)
val getInt8: int -> Int8.int
val getInt16: int -> Int16.int
val getInt32: int -> Int32.int
@@ -27,8 +29,10 @@
val register: int * (unit -> unit) -> unit
val setBool: bool -> unit
val setChar8: Char.char -> unit
+(*
val setChar16: Char16.char -> unit
val setChar32: Char32.char -> unit
+*)
val setInt8: Int8.int -> unit
val setInt16: Int16.int -> unit
val setInt32: Int32.int -> unit
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/ffi.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/ffi.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/ffi.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -8,13 +8,14 @@
structure MLtonFFI: MLTON_FFI =
struct
-structure Prim = Primitive.FFI
+structure Prim = Primitive.MLton.FFI
-structure Pointer = Primitive.Pointer
+structure Pointer = Primitive.MLton.Pointer
local
fun make (p: Pointer.t, get, set) =
- (fn i => get (p, i), fn x => set (p, 0, x))
+ (fn i => get (p, C_Ptrdiff.fromInt i),
+ fn x => set (p, C_Ptrdiff.fromInt 0, x))
in
val (getInt8, setInt8) =
make (Prim.int8Array, Pointer.getInt8, Pointer.setInt8)
@@ -24,8 +25,8 @@
make (Prim.int32Array, Pointer.getInt32, Pointer.setInt32)
val (getInt64, setInt64) =
make (Prim.int64Array, Pointer.getInt64, Pointer.setInt64)
- fun getPointer i = Pointer.getPointer (Prim.pointerArray, i)
- fun setPointer x = Pointer.setPointer (Prim.pointerArray, 0, x)
+ fun getPointer i = Pointer.getPointer (Prim.pointerArray, C_Ptrdiff.fromInt i)
+ fun setPointer x = Pointer.setPointer (Prim.pointerArray, C_Ptrdiff.fromInt 0, x)
val (getReal32, setReal32) =
make (Prim.real32Array, Pointer.getReal32, Pointer.setReal32)
val (getReal64, setReal64) =
@@ -45,20 +46,20 @@
val register = MLtonThread.register
(* To the C-world, booleans and chars are signed integers. *)
-fun intToBool (i: int): bool = i <> 0
+fun intToBool (i: Int32.t): bool = i <> 0
val getBool = intToBool o getInt32
-val getChar8 = Primitive.Char.fromInt8 o getInt8
-val getChar16 = Primitive.Char2.fromInt16 o getInt16
-val getChar32 = Primitive.Char4.fromInt32 o getInt32
+val getChar8 = Primitive.Char8.fromInt8Unsafe o getInt8
+val getChar16 = Primitive.Char16.fromInt16Unsafe o getInt16
+val getChar32 = Primitive.Char32.fromInt32Unsafe o getInt32
-fun boolToInt (b: bool): int = if b then 1 else 0
+fun boolToInt (b: bool): Int32.t = if b then 1 else 0
val setBool = setInt32 o boolToInt
-val setChar8 = setInt8 o Primitive.Char.toInt8
-val setChar16 = setInt16 o Primitive.Char2.toInt16
-val setChar32 = setInt32 o Primitive.Char4.toInt32
+val setChar8 = setInt8 o Primitive.Char8.toInt8Unsafe
+val setChar16 = setInt16 o Primitive.Char16.toInt16Unsafe
+val setChar32 = setInt32 o Primitive.Char32.toInt32Unsafe
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/finalizable.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/finalizable.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/finalizable.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -21,7 +21,7 @@
finalizers: ('a -> unit) list ref,
value: 'a ref}
-fun touch (T {value, ...}) = Primitive.touch value
+fun touch (T {value, ...}) = Primitive.MLton.Finalizable.touch value
fun withValue (f as T {value, ...}, g) =
DynamicWind.wind (fn () => g (!value),
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/gc.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/gc.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/gc.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -8,9 +8,9 @@
structure MLtonGC =
struct
- open Primitive.GC
+ open Primitive.MLton.GC
- val gcState = Primitive.GCState.gcState
+ val gcState = Primitive.MLton.GCState.gcState
val pack : unit -> unit =
fn () => pack gcState
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/int-inf.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/int-inf.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/int-inf.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -5,18 +5,18 @@
* See the file MLton-LICENSE for details.
*)
-type int = Int.int
-type word = Word.word
-
signature MLTON_INT_INF =
sig
type t
+
+ structure BigWord : WORD
+ structure SmallInt : INTEGER
val areSmall: t * t -> bool
val gcd: t * t -> t
val isSmall: t -> bool
datatype rep =
- Big of word vector
- | Small of int
+ Big of BigWord.word vector
+ | Small of SmallInt.int
val rep: t -> rep
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/itimer.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/itimer.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/itimer.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -26,9 +26,10 @@
let
fun split t =
let
- val (q, r) = IntInf.quotRem (Time.toMicroseconds t, 1000000)
+ val q = LargeInt.quot (Time.toMicroseconds t, 1000000)
+ val r = LargeInt.rem (Time.toMicroseconds t, 1000000)
in
- (IntInf.toInt q, IntInf.toInt r)
+ (C_Time.fromLarge q, C_SUSeconds.fromLarge r)
end
val (s1, u1) = split interval
val (s2, u2) = split value
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/mlton.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/mlton.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/mlton.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -27,16 +27,19 @@
; GC.collect ())
fun size x =
- let val refOverhead = 8 (* header + indirect *)
- in Primitive.MLton.size (ref x) - refOverhead
+ let
+ val refOverhead =
+ Int.div (HeaderWord.wordSize + ObjptrWord.wordSize, 8)
+ in
+ C_Size.toInt (Primitive.MLton.size (ref x)) - refOverhead
end
(* fun cleanAtExit () = let open Cleaner in clean atExit end *)
-val debug = Primitive.debug
-val eq = Primitive.eq
+val debug = Primitive.Controls.debug
+val eq = Primitive.MLton.eq
(* val errno = Primitive.errno *)
-val safe = Primitive.safe
+val safe = Primitive.Controls.safe
structure Array = Array
structure BinIO = MLtonIO (BinIO)
@@ -69,12 +72,12 @@
structure World = MLtonWorld
structure Word =
struct
- open Primitive.Word32
+ open Word
type t = word
end
structure Word8 =
struct
- open Primitive.Word8
+ open Word8
type t = word
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/pointer.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/pointer.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/pointer.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -5,9 +5,6 @@
* See the file MLton-LICENSE for details.
*)
-type int = Int.int
-type word = Word.word
-
signature MLTON_POINTER =
sig
eqtype t
@@ -15,7 +12,7 @@
val add: t * word -> t
val compare: t * t -> order
val diff: t * t -> word
-(* val free: t -> unit *)
+ (* val free: t -> unit *)
val getInt8: t * int -> Int8.int
val getInt16: t * int -> Int16.int
val getInt32: t * int -> Int32.int
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/pointer.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/pointer.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/pointer.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -8,11 +8,45 @@
structure MLtonPointer: MLTON_POINTER =
struct
-open Primitive.Pointer
+open Primitive.MLton.Pointer
-fun add (p, t) = fromWord (Word.+ (toWord p, t))
-fun compare (p, p') = Word.compare (toWord p, toWord p')
-fun diff (p, p') = Word.- (toWord p, toWord p')
-fun sub (p, t) = fromWord (Word.- (toWord p, t))
-
+fun add (p, t) = fromWord (C_Pointer.+ (toWord p, C_Pointer.fromWord t))
+fun compare (p, p') = C_Pointer.compare (toWord p, toWord p')
+fun diff (p, p') = C_Pointer.toWord (C_Pointer.- (toWord p, toWord p'))
+fun sub (p, t) = fromWord (C_Pointer.- (toWord p, C_Pointer.fromWord t))
+
+local
+ fun wrap f (p, i) =
+ f (p, C_Ptrdiff.fromInt i)
+in
+ val getInt8 = wrap getInt8
+ val getInt16 = wrap getInt16
+ val getInt32 = wrap getInt32
+ val getInt64 = wrap getInt64
+ val getPointer = wrap getPointer
+ val getReal32 = wrap getReal32
+ val getReal64 = wrap getReal64
+ val getWord8 = wrap getWord8
+ val getWord16 = wrap getWord16
+ val getWord32 = wrap getWord32
+ val getWord64 = wrap getWord64
end
+
+local
+ fun wrap f (p, i, x) =
+ f (p, C_Ptrdiff.fromInt i, x)
+in
+ val setInt8 = wrap setInt8
+ val setInt16 = wrap setInt16
+ val setInt32 = wrap setInt32
+ val setInt64 = wrap setInt64
+ val setPointer = wrap setPointer
+ val setReal32 = wrap setReal32
+ val setReal64 = wrap setReal64
+ val setWord8 = wrap setWord8
+ val setWord16 = wrap setWord16
+ val setWord32 = wrap setWord32
+ val setWord64 = wrap setWord64
+end
+
+end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/proc-env.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/proc-env.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/proc-env.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -25,6 +25,6 @@
val n = Vector.length v
in
PosixError.SysCall.simple
- (fn () => PrimitiveFFI.Posix.ProcEnv.setgroups (n, v))
+ (fn () => PrimitiveFFI.Posix.ProcEnv.setgroups (C_Int.fromInt n, v))
end
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/process.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/process.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/process.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -20,7 +20,7 @@
structure Mask = MLtonSignal.Mask
structure SysCall = PosixError.SysCall
- type pid = Pid.t
+ type pid = C_PId.t
exception MisuseOfForget
exception DoublyRedirected
@@ -254,9 +254,10 @@
dquote]
fun create (cmd, args, env, stdin, stdout, stderr) =
- SysCall.syscall
- (fn () =>
+ SysCall.simpleResult'
+ ({errVal = C_PId.fromInt ~1}, fn () =>
let
+(*
val cmd =
let
open MLton.Platform.OS
@@ -266,12 +267,10 @@
| MinGW => cmd
| _ => raise Fail "create"
end
- val p =
- PrimitiveFFI.Windows.Process.create
- (NullString.nullTerm cmd, args, env, stdin, stdout, stderr)
- val p' = Pid.toInt p
+*)
in
- (p', fn () => p)
+ PrimitiveFFI.Windows.Process.create
+ (NullString.nullTerm cmd, args, env, stdin, stdout, stderr)
end)
fun launchWithCreate (path, args, env, stdin, stdout, stderr) =
@@ -322,14 +321,12 @@
then
let
val path = NullString.nullTerm path
- val args = COld.CSS.fromList args
- val env = COld.CSS.fromList env
+ val args = CUtil.C_StringArray.fromList args
+ val env = CUtil.C_StringArray.fromList env
in
- SysCall.syscall
- (fn () =>
- let val pid = Prim.spawne (path, args, env)
- in (Pid.toInt pid, fn () => pid)
- end)
+ SysCall.simpleResult'
+ ({errVal = C_PId.fromInt ~1}, fn () =>
+ Prim.spawne (path, args, env))
end
else
case Posix.Process.fork () of
@@ -346,13 +343,11 @@
then
let
val file = NullString.nullTerm file
- val args = COld.CSS.fromList args
+ val args = CUtil.C_StringArray.fromList args
in
- SysCall.syscall
- (fn () =>
- let val pid = Prim.spawnp (file, args)
- in (Pid.toInt pid, fn () => pid)
- end)
+ SysCall.simpleResult'
+ ({errVal = C_PId.fromInt ~1}, fn () =>
+ Prim.spawnp (file, args))
end
else
case Posix.Process.fork () of
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/profile.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/profile.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/profile.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -10,7 +10,7 @@
structure P = Primitive.MLton.Profile
-val gcState = Primitive.GCState.gcState
+val gcState = Primitive.MLton.GCState.gcState
val isOn = P.isOn
@@ -81,7 +81,7 @@
creat (file,
flags [irusr, iwusr, irgrp, iwgrp, iroth, iwoth])
end
- val _ = P.Data.write (gcState, raw, Posix.FileSys.fdToWord fd)
+ val _ = P.Data.write (gcState, raw, fd)
val _ = Posix.IO.close fd
in
()
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/random.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/random.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/random.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -5,9 +5,6 @@
* MLton is released under a BSD-style license.
* See the file MLton-LICENSE for details.
*)
-
-type int = Int.int
-type word = Word.word
signature MLTON_RANDOM =
sig
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/rlimit.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/rlimit.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/rlimit.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -8,9 +8,9 @@
signature MLTON_RLIMIT =
sig
- type rlim = Word64.word
+ structure RLim : WORD
- val infinity: rlim
+ val infinity: RLim.word
type t
@@ -27,7 +27,7 @@
val numProcesses: t (* NPROC max number of processes *)
val residentSetSize: t (* RSS max resident set size *)
*)
-
- val get: t -> {hard: rlim, soft: rlim}
- val set: t * {hard: rlim, soft: rlim} -> unit
+
+ val get: t -> {hard: RLim.word, soft: RLim.word}
+ val set: t * {hard: RLim.word, soft: RLim.word} -> unit
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/rlimit.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/rlimit.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/rlimit.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -9,14 +9,14 @@
structure MLtonRlimit: MLTON_RLIMIT =
struct
open PrimitiveFFI.MLton.Rlimit
- type rlim = C_RLim.t
+ structure RLim = C_RLim
type t = C_Int.t
val get =
fn (r: t) =>
PosixError.SysCall.syscall
(fn () =>
- (get r, fn () =>
+ (get r, fn _ =>
{hard = getHard (),
soft = getSoft ()}))
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/rusage.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/rusage.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/rusage.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -17,9 +17,9 @@
fun toTime (sec, usec) =
let
val time_sec =
- Time.fromSeconds (LargeInt.fromInt (sec ()))
+ Time.fromSeconds (C_Time.toLarge (sec ()))
val time_usec =
- Time.fromMicroseconds (LargeInt.fromInt (usec ()))
+ Time.fromMicroseconds (C_SUSeconds.toLarge (usec ()))
in
Time.+ (time_sec, time_usec)
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/signal.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/signal.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/signal.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -18,8 +18,6 @@
type t = signal
type how = C_Int.t
-
-(* val toString = SysWord.toString o toWord *)
fun raiseInval () =
let
@@ -30,8 +28,12 @@
val validSignals =
Array.tabulate
- (Prim.NSIG, fn i =>
- Prim.sigismember(fromInt i) <> ~1)
+ (C_Int.toInt Prim.NSIG, fn i =>
+ SysCall.syscallErr
+ ({clear = false, restart = false, errVal = C_Int.fromInt ~1}, fn () =>
+ {return = Prim.sigismember (fromInt i),
+ post = fn _ => true,
+ handlers = [(Error.inval, fn () => false)]}))
structure Mask =
struct
@@ -50,9 +52,16 @@
(Array.foldri
(fn (i, b, sigs) =>
if b
- then if (Prim.sigismember(fromInt i)) = 1
- then (fromInt i)::sigs
- else sigs
+ then let
+ val s = fromInt i
+ val res =
+ SysCall.simpleResult
+ (fn () => Prim.sigismember s)
+ in
+ if res = C_Int.fromInt 1
+ then s::sigs
+ else sigs
+ end
else sigs)
[]
validSignals)
@@ -103,16 +112,16 @@
val r = ref false
in
fun initHandler (s: signal): Handler.t =
- if 0 = Prim.isDefault (s, r)
- then if !r
- then Default
- else Ignore
- else InvalidSignal
+ SysCall.syscallErr
+ ({clear = false, restart = false, errVal = C_Int.fromInt ~1}, fn () =>
+ {return = Prim.isDefault (s, r),
+ post = fn _ => if !r then Default else Ignore,
+ handlers = [(Error.inval, fn () => InvalidSignal)]})
end
val (getHandler, setHandler, handlers) =
let
- val handlers = Array.tabulate (Prim.NSIG, initHandler o fromInt)
+ val handlers = Array.tabulate (C_Int.toInt Prim.NSIG, initHandler o fromInt)
val _ =
Cleaner.addNew
(Cleaner.atLoadWorld, fn () =>
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/socket.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/socket.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/socket.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -6,14 +6,11 @@
* See the file MLton-LICENSE for details.
*)
-type int = Int.int
-type word = Word.word
-
signature MLTON_SOCKET =
sig
structure Address:
sig
- type t = word
+ type t
end
structure Ctl:
@@ -33,7 +30,7 @@
structure Port:
sig
- type t = int
+ type t
end
type t
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/socket.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/socket.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/socket.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -16,7 +16,7 @@
structure Address =
struct
- type t = word
+ type t = NetHostDB.in_addr
end
structure Host =
@@ -26,7 +26,7 @@
val get: NetHostDB.entry option -> t option =
Option.map (fn entry => {name = NetHostDB.name entry})
- val getByAddress = get o NetHostDB.getByAddr o NetHostDB.wordToInAddr
+ val getByAddress = get o NetHostDB.getByAddr
val getByName = get o NetHostDB.getByName
end
@@ -75,7 +75,7 @@
val (in_addr: NetHostDB.in_addr, port: int) = INetSock.fromAddr addr
val (ins, out) = sockToIO sock
in
- (NetHostDB.inAddrToWord in_addr, port, ins, out)
+ (in_addr, port, ins, out)
end
fun connect (host, port) =
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/syslog.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/syslog.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/syslog.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -70,20 +70,17 @@
val WARNING = LOG_WARNING
end
-fun zt s = s ^ "\000"
-
val openlog = fn (s, opt, fac) =>
let
- val optf =
- Word32.toInt (foldl Word32.orb 0w0 (map Word32.fromInt opt))
+ val optf = foldl C_Int.orb 0 opt
in
- openlog (NullString.fromString (zt s), optf, fac)
+ openlog (NullString.nullTerm s, optf, fac)
end
val closelog = fn () =>
closelog ()
val log = fn (lev, msg) =>
- syslog (lev, NullString.fromString (zt msg))
+ syslog (lev, NullString.nullTerm msg)
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/thread.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/thread.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/thread.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -8,10 +8,17 @@
structure MLtonThread:> MLTON_THREAD_EXTRA =
struct
-structure Prim = Primitive.Thread
+structure Prim = Primitive.MLton.Thread
-val gcState = Primitive.GCState.gcState
+fun die (s: string): 'a =
+ (PrimitiveFFI.Stdio.print s
+ ; PrimitiveFFI.Posix.Process.exit 1
+ ; let exception DieFailed
+ in raise DieFailed
+ end)
+val gcState = Primitive.MLton.GCState.gcState
+
structure AtomicState =
struct
datatype t = NonAtomic | Atomic of int
@@ -24,8 +31,8 @@
val atomicEnd = atomicEnd
val atomicState = fn () =>
case canHandle () of
- 0 => AtomicState.NonAtomic
- | n => AtomicState.Atomic n
+ 0wx0 => AtomicState.NonAtomic
+ | w => AtomicState.Atomic (Word32.toInt w)
end
fun atomically f =
@@ -167,7 +174,7 @@
fun setSignalHandler (f: Runnable.t -> Runnable.t): unit =
let
- val _ = Primitive.installSignalHandler ()
+ val _ = Primitive.MLton.installSignalHandler ()
fun loop (): unit =
let
(* Atomic 1 *)
@@ -217,8 +224,9 @@
in
val register: int * (unit -> unit) -> unit =
let
- val exports = Array.array (Primitive.FFI.numExports, fn () =>
- raise Fail "undefined export")
+ val exports =
+ Array.array (Int32.toInt (Primitive.MLton.FFI.numExports),
+ fn () => raise Fail "undefined export")
fun loop (): unit =
let
(* Atomic 2 *)
@@ -228,7 +236,7 @@
(* Atomic 1 *)
val _ =
(* atomicEnd() after getting args *)
- (Array.sub (exports, Primitive.FFI.getOp ()) ())
+ (Array.sub (exports, Int32.toInt (Primitive.MLton.FFI.getOp ())) ())
handle e =>
(TextIO.output
(TextIO.stdErr, "Call from C to SML raised exception.\n")
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/vector.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/vector.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/vector.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -10,7 +10,7 @@
signature MLTON_VECTOR =
sig
- val create:
+ val create:
int * ({sub: int -> 'a, update: int * 'a -> unit}
-> (int -> 'a) * (unit -> unit))
-> 'a vector
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/word.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/word.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/word.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -5,8 +5,6 @@
* MLton is released under a BSD-style license.
* See the file MLton-LICENSE for details.
*)
-
-type word = Word.word
signature MLTON_WORD =
sig
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/world.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/world.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/world.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -8,9 +8,9 @@
structure MLtonWorld: MLTON_WORLD =
struct
- structure Prim = Primitive.World
+ structure Prim = Primitive.MLton.World
- val gcState = Primitive.GCState.gcState
+ val gcState = Primitive.MLton.GCState.gcState
datatype status = Clone | Original
@@ -24,8 +24,7 @@
let
open Posix.FileSys
val flags =
- O.flags [O.trunc,
- SysWord.fromInt PrimitiveFFI.Posix.FileSys.O.BINARY]
+ O.flags [O.trunc, PrimitiveFFI.Posix.FileSys.O.BINARY]
val mode =
let
open S
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/net/generic-sock.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/net/generic-sock.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/net/generic-sock.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -11,27 +11,19 @@
structure PE = Posix.Error
structure PESC = PE.SysCall
- fun intToSock i = Socket.wordToSock (SysWord.fromInt i)
-
fun socket' (af, st, p) =
- PESC.syscall
- (fn () =>
- let val n = Prim.socket (NetHostDB.addrFamilyToInt af, st, p)
- in (n, fn () => intToSock n)
- end)
+ PESC.simpleResult
+ (fn () => Prim.socket (af, st, C_Int.fromInt p))
fun socketPair' (af, st, p) =
let
val a = Array.array (2, 0)
in
PESC.syscall
- (fn () =>
- let val n = Prim.socketPair (NetHostDB.addrFamilyToInt af, st, p, a)
- in (n, fn () => (intToSock (Array.sub (a, 0)),
- intToSock (Array.sub (a, 1))))
- end)
+ (fn () => (Prim.socketPair (af, st, C_Int.fromInt p, a), fn _ =>
+ (Array.sub (a, 0), Array.sub (a, 1))))
end
-
+
fun socket (af, st) = socket' (af, st, 0)
fun socketPair (af, st) = socketPair' (af, st, 0)
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/net/inet-sock.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/net/inet-sock.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/net/inet-sock.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -15,29 +15,32 @@
type dgram_sock = Socket.dgram sock
type sock_addr = inet Socket.sock_addr
- val inetAF = NetHostDB.intToAddrFamily PrimitiveFFI.Socket.AF.INET
+ val inetAF = PrimitiveFFI.Socket.AF.INET
fun toAddr (in_addr, port) =
- let val port = Net.htonl port
+ let
+ val port = C_Int.fromInt port
+ val port = Net.C_Int.hton port
in
- if port < 0 orelse port >= 0x10000
- then PosixError.raiseSys PosixError.inval
- else
- let
- val (sa, salen, finish) = Socket.new_sock_addr ()
- val _ = Prim.toAddr (NetHostDB.inAddrToWord8Vector in_addr,
- port, sa, salen)
- in
- finish ()
- end
+ if C_Int.< (port, 0) orelse C_Int.>= (port, 0x10000)
+ then PosixError.raiseSys PosixError.inval
+ else let
+ val (sa, salen, finish) = Socket.new_sock_addr ()
+ val _ = Prim.toAddr (NetHostDB.inAddrToWord8Vector in_addr,
+ port, sa, salen)
+ in
+ finish ()
+ end
end
fun any port = toAddr (NetHostDB.any (), port)
fun fromAddr sa =
let
- val _ = Prim.fromAddr (Word8Vector.toPoly (Socket.unpackSockAddr sa))
- val port = Net.ntohl (Prim.getPort ())
+ val () = Prim.fromAddr (Socket.unpackSockAddr sa)
+ val port = Prim.getPort ()
+ val port = Net.C_Int.ntoh port
+ val port = C_Int.toInt port
val (ia, finish) = NetHostDB.new_in_addr ()
val _ = Prim.getInAddr (NetHostDB.preInAddrToWord8Array ia)
in
@@ -46,27 +49,23 @@
structure UDP =
struct
- fun socket' prot =
- GenericSock.socket' (inetAF, Socket.SOCK.dgram, prot)
-
+ fun socket' prot = GenericSock.socket' (inetAF, Socket.SOCK.dgram, prot)
fun socket () = socket' 0
end
structure TCP =
struct
structure Prim = Prim.Ctl
-
- fun socket' prot =
- GenericSock.socket' (inetAF, Socket.SOCK.stream, prot)
+ fun socket' prot = GenericSock.socket' (inetAF, Socket.SOCK.stream, prot)
fun socket () = socket' 0
-
+
fun getNODELAY sock =
- Socket.CtlExtra.getSockOptBool
- (Prim.IPPROTO_TCP, Prim.TCP_NODELAY) sock
-
- fun setNODELAY (sock,optval) =
- Socket.CtlExtra.setSockOptBool
- (Prim.IPPROTO_TCP, Prim.TCP_NODELAY) (sock,optval)
+ Socket.CtlExtra.getSockOptBool
+ (Prim.IPPROTO_TCP, Prim.TCP_NODELAY) sock
+
+ fun setNODELAY (sock, optval) =
+ Socket.CtlExtra.setSockOptBool
+ (Prim.IPPROTO_TCP, Prim.TCP_NODELAY) (sock,optval)
end
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/net/net-host-db.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/net/net-host-db.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/net/net-host-db.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -22,12 +22,8 @@
include NET_HOST_DB
type pre_in_addr
- val addrFamilyToInt: addr_family -> int
val any: unit -> in_addr
val inAddrToWord8Vector: in_addr -> Word8.word vector
- val inAddrToWord: in_addr -> word
- val intToAddrFamily: int -> addr_family
val new_in_addr: unit -> pre_in_addr * (unit -> in_addr)
val preInAddrToWord8Array: pre_in_addr -> Word8.word array
- val wordToInAddr: word -> in_addr
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/net/net-host-db.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/net/net-host-db.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/net/net-host-db.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -5,40 +5,45 @@
* See the file MLton-LICENSE for details.
*)
-structure NetHostDB:> NET_HOST_DB_EXTRA =
+structure NetHostDB: NET_HOST_DB_EXTRA =
struct
structure Prim = PrimitiveFFI.NetHostDB
- (* network byte order (MSB) *)
+ (* network byte order (big-endian) *)
type pre_in_addr = Word8.word array
type in_addr = Word8.word vector
val preInAddrToWord8Array = fn a => a
val inAddrToWord8Vector = fn v => v
-
- structure PW = PackWord32Big
+
+ val inAddrLen = C_Size.toInt Prim.inAddrSize
fun new_in_addr () =
let
- val inAddrLen = Word32.toIntX Prim.inAddrSize
val ia: pre_in_addr = Array.array (inAddrLen, 0wx0: Word8.word)
fun finish () = Array.vector ia
in
(ia, finish)
end
- fun inAddrToWord (ia: in_addr) =
- Word.fromLargeWord (PW.subVec (Word8Vector.fromPoly ia, 0))
- fun wordToInAddr w =
- let
- val (ia, finish) = new_in_addr ()
- val _ = PW.update (Word8Array.fromPoly ia, 0, Word.toLargeWord w)
- in
- finish ()
- end
- fun any () = wordToInAddr (Word.fromInt Prim.INADDR_ANY)
+ fun any () =
+ let
+ val (wa, finish) = new_in_addr ()
+ fun loop (i, acc) =
+ if i >= inAddrLen
+ then ()
+ else let
+ val w = Word8.fromSysWord (C_Int.toSysWord acc)
+ val () =
+ Array.update
+ (wa, (inAddrLen - 1) - i, w)
+ in
+ loop (i + 1, C_Int.>> (acc, 0w4))
+ end
+ in
+ loop (0, Prim.INADDR_ANY)
+ ; finish ()
+ end
+
type addr_family = C_Int.t
-
- val intToAddrFamily = fn z => z
- val addrFamilyToInt = fn z => z
datatype entry = T of {name: string,
aliases: string list,
@@ -59,15 +64,15 @@
fun get (b: bool): entry option =
if b
then let
- val name = COld.CS.toString (Prim.getEntryName ())
+ val name = CUtil.C_String.toString (Prim.getEntryName ())
val numAliases = Prim.getEntryAliasesNum ()
fun fill (n, aliases) =
- if n < numAliases
+ if C_Int.< (n, numAliases)
then let
val alias =
- COld.CS.toString (Prim.getEntryAliasesN n)
+ CUtil.C_String.toString (Prim.getEntryAliasesN n)
in
- fill (n + 1, alias::aliases)
+ fill (C_Int.+ (n, 1), alias::aliases)
end
else List.rev aliases
val aliases = fill (0, [])
@@ -75,15 +80,13 @@
val length = Prim.getEntryLength ()
val numAddrs = Prim.getEntryAddrsNum ()
fun fill (n, addrs) =
- if n < numAddrs
+ if C_Int.< (n, numAddrs)
then let
- val addr = Word8Array.array (length, 0wx0)
- val _ =
- Prim.getEntryAddrsN (n, Word8Array.toPoly addr)
- val addr =
- Word8Vector.toPoly (Word8Array.vector addr)
+ val addr = Word8Array.array (C_Int.toInt length, 0wx0)
+ val _ = Prim.getEntryAddrsN (n, Word8Array.toPoly addr)
+ val addr = Word8Vector.toPoly (Word8Array.vector addr)
in
- fill (n + 1, addr::addrs)
+ fill (C_Int.+ (n, 1), addr::addrs)
end
else List.rev addrs
val addrs = fill (0, [])
@@ -145,8 +148,8 @@
end
val l = loop (4, state, [])
fun get1 w =
- (Word8.fromLarge (Word32.toLarge (Word32.andb (w, 0wxFF))),
- Word32.>>(w, 0w8))
+ (Word8.fromLarge (Word.toLarge (Word.andb (w, 0wxFF))),
+ Word.>>(w, 0w8))
fun get2 w =
let
val (a,w) = get1 w
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/net/net-prot-db.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/net/net-prot-db.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/net/net-prot-db.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -11,29 +11,28 @@
datatype entry = T of {name: string,
aliases: string list,
- protocol: int}
+ protocol: C_Int.t}
local
fun make s (T r) = s r
in
val name = make #name
val aliases = make #aliases
- val protocol = make #protocol
+ val protocol = C_Int.toInt o (make #protocol)
end
local
fun get (b: bool): entry option =
if b
then let
- val name = COld.CS.toString (Prim.getEntryName ())
+ val name = CUtil.C_String.toString (Prim.getEntryName ())
val numAliases = Prim.getEntryAliasesNum ()
fun fill (n, aliases) =
- if n < numAliases
+ if C_Int.< (n, numAliases)
then let
- val alias =
- COld.CS.toString (Prim.getEntryAliasesN n)
+ val alias = CUtil.C_String.toString (Prim.getEntryAliasesN n)
in
- fill (n + 1, alias::aliases)
+ fill (C_Int.+ (n, 1), alias::aliases)
end
else List.rev aliases
val aliases = fill (0, [])
@@ -48,6 +47,6 @@
fun getByName name =
get (Prim.getByName (NullString.nullTerm name))
fun getByNumber proto =
- get (Prim.getByNumber proto)
+ get (Prim.getByNumber (C_Int.fromInt proto))
end
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/net/net-serv-db.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/net/net-serv-db.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/net/net-serv-db.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -11,7 +11,7 @@
datatype entry = T of {name: string,
aliases: string list,
- port: int,
+ port: C_Int.t,
protocol: string}
local
@@ -19,7 +19,7 @@
in
val name = make #name
val aliases = make #aliases
- val port = make #port
+ val port = C_Int.toInt o (make #port)
val protocol = make #protocol
end
@@ -27,20 +27,19 @@
fun get (b: bool): entry option =
if b
then let
- val name = COld.CS.toString (Prim.getEntryName ())
+ val name = CUtil.C_String.toString (Prim.getEntryName ())
val numAliases = Prim.getEntryAliasesNum ()
fun fill (n, aliases) =
- if n < numAliases
+ if C_Int.< (n, numAliases)
then let
- val alias =
- COld.CS.toString (Prim.getEntryAliasesN n)
+ val alias = CUtil.C_String.toString (Prim.getEntryAliasesN n)
in
- fill (n + 1, alias::aliases)
+ fill (C_Int.+ (n, 1), alias::aliases)
end
else List.rev aliases
val aliases = fill (0, [])
- val port = Net.ntohl (Prim.getEntryPort ())
- val protocol = COld.CS.toString (Prim.getEntryProto ())
+ val port = Net.C_Int.ntoh (Prim.getEntryPort ())
+ val protocol = CUtil.C_String.toString (Prim.getEntryProto ())
in
SOME (T {name = name,
aliases = aliases,
@@ -56,7 +55,7 @@
| NONE => get (Prim.getByNameNull (NullString.nullTerm name))
fun getByPort (port, proto) =
let
- val port = Net.htonl port
+ val port = Net.C_Int.hton (C_Int.fromInt port)
in
case proto of
NONE => get (Prim.getByPortNull port)
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/net/net.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/net/net.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/net/net.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -1,7 +1,15 @@
+(* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh
+ * Jagannathan, and Stephen Weeks.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ *)
+
signature NET =
sig
- val htonl: Int32.int -> Int32.int
- val ntohl: Int32.int -> Int32.int
- val htons: Int16.int -> Int16.int
- val ntohs: Int16.int -> Int16.int
+ structure C_Int :
+ sig
+ val hton: C_Int.t -> C_Int.t
+ val ntoh: C_Int.t -> C_Int.t
+ end
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/net/net.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/net/net.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/net/net.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -9,8 +9,51 @@
struct
structure Prim = PrimitiveFFI.Net
- val htonl = Primitive.Word32.toInt32 o Prim.htonl o Primitive.Word32.fromInt32
- val ntohl = Primitive.Word32.toInt32 o Prim.ntohl o Primitive.Word32.fromInt32
- val htons = Primitive.Word16.toInt16 o Prim.htons o Primitive.Word16.fromInt16
- val ntohs = Primitive.Word16.toInt16 o Prim.ntohs o Primitive.Word16.fromInt16
+ structure Word32 =
+ struct
+ val hton = Prim.htonl
+ val ntoh = Prim.ntohl
+ end
+ structure Word16 =
+ struct
+ val hton = Prim.htons
+ val ntoh = Prim.ntohs
+ end
+
+ structure Int32 =
+ struct
+ val hton = Primitive.Word32.toInt32Unsafe o Word32.hton o Primitive.Word32.fromInt32Unsafe
+ val ntoh = Primitive.Word32.toInt32Unsafe o Word32.ntoh o Primitive.Word32.fromInt32Unsafe
+ end
+ structure Int16 =
+ struct
+ val hton = Primitive.Word16.toInt16Unsafe o Word16.hton o Primitive.Word16.fromInt16Unsafe
+ val ntoh = Primitive.Word16.toInt16Unsafe o Word16.ntoh o Primitive.Word16.fromInt16Unsafe
+ end
+
+ structure C_Int =
+ struct
+ local
+ structure S =
+ C_Int_ChooseIntN
+ (type 'a t = 'a -> 'a
+ val fInt8 = fn _ => raise Fail "Net.C_Int.hton: fInt8"
+ val fInt16 = Int16.hton
+ val fInt32 = Int32.hton
+ val fInt64 = fn _ => raise Fail "Net.C_Int.hton: fInt64")
+ in
+ val hton = S.f
+ end
+ local
+ structure S =
+ C_Int_ChooseIntN
+ (type 'a t = 'a -> 'a
+ val fInt8 = fn _ => raise Fail "Net.C_Int.ntoh: fInt8"
+ val fInt16 = Int16.ntoh
+ val fInt32 = Int32.ntoh
+ val fInt64 = fn _ => raise Fail "Net.C_Int.ntoh: fInt64")
+ in
+ val ntoh = S.f
+ end
+ end
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/net/socket.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/net/socket.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/net/socket.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -170,34 +170,24 @@
val sockToFD: ('af, 'sock_type) sock -> Posix.FileSys.file_desc
val fdToSock: Posix.FileSys.file_desc -> ('af, 'sock_type) sock
type pre_sock_addr
- val unpackSockAddr: 'af sock_addr -> Word8Vector.vector
+ val unpackSockAddr: 'af sock_addr -> Word8.word vector
val new_sock_addr: unit -> (pre_sock_addr * C_Socklen.t ref * (unit -> 'af sock_addr))
structure CtlExtra:
sig
- type level = int
- type optname = int
- type request = int
+ type level = C_Int.int
+ type optname = C_Int.int
+ type request = C_Int.int
-(* val getSockOptWord: level * optname -> ('af, 'sock_type) sock -> word *)
-(* val setSockOptWord:
- * level * optname -> ('af, 'sock_type) sock * word -> unit
- *)
- val getERROR:
- ('af, 'sock_type) sock
- -> (string * Posix.Error.syserror option) option
- val getSockOptInt: level * optname -> ('af, 'sock_type) sock -> int
- val setSockOptInt:
- level * optname -> ('af, 'sock_type) sock * int -> unit
+ val getERROR: ('af, 'sock_type) sock -> (string * Posix.Error.syserror option) option
+ val getSockOptInt: level * optname -> ('af, 'sock_type) sock -> C_Int.int
+ val setSockOptInt: level * optname -> ('af, 'sock_type) sock * C_Int.int -> unit
val getSockOptBool: level * optname -> ('af, 'sock_type) sock -> bool
- val setSockOptBool:
- level * optname -> ('af, 'sock_type) sock * bool -> unit
+ val setSockOptBool: level * optname -> ('af, 'sock_type) sock * bool -> unit
-(* val getIOCtlWord: request -> ('af, 'sock_type) sock -> word *)
-(* val setIOCtlWord: request -> ('af, 'sock_type) sock * word -> unit *)
- val getIOCtlInt: request -> ('af, 'sock_type) sock -> int
-(* val setIOCtlInt: request -> ('af, 'sock_type) sock * int -> unit *)
+ val getIOCtlInt: request -> ('af, 'sock_type) sock -> C_Int.int
+ (* val setIOCtlInt: request -> ('af, 'sock_type) sock * C_Int.int -> unit *)
val getIOCtlBool: request -> ('af, 'sock_type) sock -> bool
-(* val setIOCtlBool: request -> ('af, 'sock_type) sock * bool -> unit *)
+ (* val setIOCtlBool: request -> ('af, 'sock_type) sock * bool -> unit *)
end
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/net/socket.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/net/socket.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/net/socket.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -5,10 +5,7 @@
* See the file MLton-LICENSE for details.
*)
-structure Socket:> SOCKET_EXTRA
- where type SOCK.sock_type = C_Int.t
- where type pre_sock_addr = Word8.word array
-=
+structure Socket : SOCKET_EXTRA =
struct
structure Prim = PrimitiveFFI.Socket
@@ -17,22 +14,22 @@
structure FileSys = Posix.FileSys
type sock = C_Sock.t
-val sockToWord = SysWord.fromInt o C_Sock.toInt
-val wordToSock = C_Sock.fromInt o SysWord.toInt
-fun sockToFD sock = FileSys.wordToFD (sockToWord sock)
-fun fdToSock fd = wordToSock (FileSys.fdToWord fd)
+val sockToWord = C_Sock.toSysWord
+val wordToSock = C_Sock.fromSysWord
+val sockToFD = fn x => x
+val fdToSock = fn x => x
type pre_sock_addr = Word8.word array
datatype sock_addr = SA of Word8.word vector
-fun unpackSockAddr (SA sa) = Word8Vector.fromPoly sa
+fun unpackSockAddr (SA sa) = sa
fun new_sock_addr (): (pre_sock_addr * C_Socklen.t ref * (unit -> sock_addr)) =
let
val salen = C_Size.toInt Prim.sockAddrStorageLen
val sa = Array.array (salen, 0wx0)
val salenRef = ref (C_Socklen.fromInt salen)
- fun finish () =
- SA (ArraySlice.vector (ArraySlice.slice
- (sa, 0, SOME (C_Socklen.toInt (!salenRef)))))
+ fun finish () =
+ SA (ArraySlice.vector
+ (ArraySlice.slice (sa, 0, SOME (C_Socklen.toInt (!salenRef)))))
in
(sa, salenRef, finish)
end
@@ -44,13 +41,12 @@
structure AF =
struct
type addr_family = NetHostDB.addr_family
- val i2a = NetHostDB.intToAddrFamily
- val names = [
- ("UNIX", i2a Prim.AF.UNIX),
- ("INET", i2a Prim.AF.INET),
- ("INET6", i2a Prim.AF.INET6),
- ("UNSPEC", i2a Prim.AF.UNSPEC)
- ]
+ val names : (string * addr_family) list =
+ ("UNIX", Prim.AF.UNIX) ::
+ ("INET", Prim.AF.INET) ::
+ ("INET6", Prim.AF.INET6) ::
+ ("UNSPEC", Prim.AF.UNSPEC) ::
+ nil
fun list () = names
fun toString af' =
case List.find (fn (_, af) => af = af') names of
@@ -67,10 +63,10 @@
type sock_type = C_Int.t
val stream = Prim.SOCK.STREAM
val dgram = Prim.SOCK.DGRAM
- val names = [
- ("STREAM", stream),
- ("DGRAM", dgram)
- ]
+ val names : (string * sock_type) list =
+ ("STREAM", stream) ::
+ ("DGRAM", dgram) ::
+ nil
fun list () = names
fun toString st' =
case List.find (fn (_, st) => st = st') names of
@@ -87,99 +83,216 @@
type level = C_Int.t
type optname = C_Int.t
type request = C_Int.t
-
+
(* host byte order *)
- structure PW = PackWord32Host
+ type optvalVec = Word8.word vector
+ type optvalArr = Word8.word array
- val wordLen = PW.bytesPerElem
- fun unmarshalWord (wa, _, s): word =
- Word.fromLargeWord (PW.subArr (wa, s))
- val intLen: int = wordLen
- fun unmarshalInt (wa, l, s): int =
- Word.toIntX (unmarshalWord (wa, l, s))
- val boolLen: int = intLen
- fun unmarshalBool (wa, l, s): bool =
- if (unmarshalInt (wa, l, s)) = 0 then false else true
- val timeOptLen: int = boolLen + intLen
- fun unmarshalTimeOpt (wa, l, s): Time.time option =
- if unmarshalBool (wa, l, s)
- then SOME (Time.fromSeconds
- (LargeInt.fromInt
- (unmarshalInt (wa, l, s + 1))))
- else NONE
-
- fun marshalWord (w, wa, s) =
- PW.update (wa, s, Word.toLargeWord w)
-
- fun marshalInt (i, wa, s) =
- marshalWord (Word.fromInt i, wa, s)
-
- fun marshalBool (b, wa, s) =
- marshalInt (if b then 1 else 0, wa, s)
-
- fun marshalTimeOpt (t, wa, s) =
- case t of
- NONE => (marshalBool (false, wa, s)
- ; marshalInt (0, wa, s + 1))
- | SOME t =>
- (marshalBool (true, wa, s)
- ; marshalWord (Word.fromLargeInt (Time.toSeconds t)
- handle Overflow => Error.raiseSys Error.inval,
- wa, s + 1))
-
+ val isBigEndian = Primitive.MLton.Platform.Arch.hostIsBigEndian
+ val intLen = Int.quot (C_Int.precision', 4)
+ fun unmarshalInt (wa: optvalArr) : C_Int.int =
+ let
+ fun loop (i, acc) =
+ if i >= intLen
+ then acc
+ else let
+ val w =
+ Array.sub
+ (wa, if isBigEndian
+ then i
+ else (intLen - 1) - i)
+ val w = C_Int.fromSysWord (Word8.toSysWord w)
+ in
+ loop (i + 1, C_Int.andb (w, C_Int.<< (acc, 0w4)))
+ end
+ in
+ loop (0, 0)
+ end
+ fun marshalInt (i: C_Int.int) : optvalVec =
+ let
+ val wa = Array.array (intLen, 0wx0)
+ fun loop (i, acc) =
+ if i >= intLen
+ then ()
+ else let
+ val w = Word8.fromSysWord (C_Int.toSysWord acc)
+ val () =
+ Array.update
+ (wa, if isBigEndian
+ then (intLen - 1) - i
+ else i, w)
+ in
+ loop (i + 1, C_Int.>> (acc, 0w4))
+ end
+ in
+ loop (0, i)
+ ; Array.vector wa
+ end
+ val boolLen = intLen
+ fun unmarshalBool (wa: optvalArr) : bool =
+ if (unmarshalInt wa) = 0 then false else true
+ fun marshalBool (b: bool) : optvalVec =
+ marshalInt (if b then 1 else 0)
+ val sizeLen = Int.quot (C_Size.wordSize, 4)
+ fun unmarshalSize (wa: optvalArr) : int =
+ let
+ fun loop (i, acc) =
+ if i >= sizeLen
+ then acc
+ else let
+ val w =
+ Array.sub
+ (wa, if isBigEndian
+ then i
+ else (sizeLen - 1) - i)
+ val w = C_Size.fromSysWord (Word8.toSysWord w)
+ in
+ loop (i + 1, C_Size.andb (w, C_Size.<< (acc, 0w4)))
+ end
+ in
+ C_Size.toInt (loop (0, 0wx0))
+ end
+ fun marshalSize (i: int) : optvalVec =
+ let
+ val wa = Array.array (sizeLen, 0wx0)
+ fun loop (i, acc) =
+ if i >= sizeLen
+ then ()
+ else let
+ val w = Word8.fromSysWord (C_Size.toSysWord acc)
+ val () =
+ Array.update
+ (wa, if isBigEndian
+ then (sizeLen - 1) - i
+ else i, w)
+ in
+ loop (i + 1, C_Size.>> (acc, 0w4))
+ end
+ in
+ loop (0, C_Size.fromInt i)
+ ; Array.vector wa
+ end
+ (* Assume 'struct linger' has no padding. *)
+ val optTimeLen: int = intLen + intLen
+ fun unmarshalOptTime (wa: optvalArr) : Time.time option =
+ let
+ fun loopBool (i, acc) =
+ if i >= intLen
+ then acc
+ else let
+ val w =
+ Array.sub
+ (wa, if isBigEndian
+ then i
+ else (intLen - 1) - i)
+ val w = C_Int.fromSysWord (Word8.toSysWord w)
+ in
+ loopBool (i + 1, C_Int.andb (w, C_Int.<< (acc, 0w4)))
+ end
+ fun loopInt (i, acc) =
+ if i >= intLen
+ then acc
+ else let
+ val w =
+ Array.sub
+ (wa, intLen + (if isBigEndian
+ then i
+ else (intLen - 1) - i))
+ val w = C_Int.fromSysWord (Word8.toSysWord w)
+ in
+ loopInt (i + 1, C_Int.andb (w, C_Int.<< (acc, 0w4)))
+ end
+ in
+ if loopBool (0, 0) = 0
+ then NONE
+ else SOME (Time.fromSeconds (C_Int.toLarge (loopInt (0, 0))))
+ end
+ fun marshalOptTime (to: Time.time option) : optvalVec =
+ let
+ val wa = Array.array (optTimeLen, 0wx0)
+ fun loopBool (i, acc) =
+ if i >= intLen
+ then ()
+ else let
+ val w = Word8.fromSysWord (C_Int.toSysWord acc)
+ val () =
+ Array.update
+ (wa, if isBigEndian
+ then (intLen - 1) - i
+ else i, w)
+ in
+ loopBool (i + 1, C_Int.>> (acc, 0w4))
+ end
+ fun loopInt (i, acc) =
+ if i >= intLen
+ then ()
+ else let
+ val w = Word8.fromSysWord (C_Int.toSysWord acc)
+ val () =
+ Array.update
+ (wa, intLen + (if isBigEndian
+ then (intLen - 1) - i
+ else i), w)
+ in
+ loopInt (i + 1, C_Int.>> (acc, 0w4))
+ end
+ in
+ case to of
+ NONE => (loopBool (0, 0); loopInt (0, 0))
+ | SOME t => (loopBool (0, 1); loopInt (0, C_Int.fromLarge (Time.toSeconds t)))
+ ; Array.vector wa
+ end
+
local
fun make (optlen: int,
- write: 'a * Word8Array.array * int -> unit,
- unmarshal: Word8Array.array * int * int -> 'a) =
+ marshal: 'a -> optvalVec,
+ unmarshal: optvalArr -> 'a) =
let
- fun marshal (x: 'a): Word8Vector.vector =
+ fun getSockOpt (level: level, optname: optname) s : 'a =
let
- val wa = Word8Array.array (optlen, 0wx0)
+ val optval = Array.array (optlen, 0wx0)
+ val optlen' = ref (C_Socklen.fromInt optlen)
+ val () =
+ Syscall.simple
+ (fn () =>
+ Prim.Ctl.getSockOpt (s, level, optname, optval, optlen'))
+ val () =
+ if C_Socklen.toInt (!optlen') <> optlen
+ then raise (Fail "Socket.Ctl.getSockOpt: optlen' <> optlen")
+ else ()
in
- write (x, wa, 0)
- ; Word8Array.vector wa
+ unmarshal optval
end
- fun getSockOpt (level: level, optname: optname) s =
+ fun setSockOpt (level: level, optname: optname) (s, optval: 'a) : unit =
let
- val optval = Word8Array.array (optlen, 0wx0)
- val optlen = ref (C_Socklen.fromInt optlen)
- in
- Syscall.simple
- (fn () =>
- Prim.Ctl.getSockOpt (s, level, optname,
- Word8Array.toPoly optval,
- optlen))
- ; unmarshal (optval, C_Socklen.toInt (!optlen), 0)
- end
- fun setSockOpt (level: level, optname: optname) (s, optval) =
- let
val optval = marshal optval
- val optlen = Word8Vector.length optval
+ val optlen' = C_Socklen.fromInt optlen
+ val () =
+ Syscall.simple
+ (fn () =>
+ Prim.Ctl.setSockOpt (s, level, optname, optval, optlen'))
in
- Syscall.simple
- (fn () =>
- Prim.Ctl.setSockOpt (s, level, optname,
- Word8Vector.toPoly optval,
- C_Socklen.fromInt optlen))
+ ()
end
fun getIOCtl (request: request) s : 'a =
let
- val optval = Word8Array.array (optlen, 0wx0)
+ val optval = Array.array (optlen, 0wx0)
+ val () =
+ Syscall.simple
+ (fn () =>
+ Prim.Ctl.getIOCtl (s, request, optval))
in
- Syscall.simple
- (fn () =>
- Prim.Ctl.getIOCtl
- (s, request, Word8Array.toPoly optval))
- ; unmarshal (optval, optlen, 0)
+ unmarshal optval
end
- fun setIOCtl (request: request) (s, optval: 'a): unit =
+ fun setIOCtl (request: request) (s, optval: 'a) : unit =
let
val optval = marshal optval
+ val () =
+ Syscall.simple
+ (fn () =>
+ Prim.Ctl.setIOCtl (s, request, optval))
in
- Syscall.simple
- (fn () =>
- Prim.Ctl.setIOCtl
- (s, request, Word8Vector.toPoly optval))
+ ()
end
in
(getSockOpt, getIOCtl, setSockOpt, setIOCtl)
@@ -189,8 +302,10 @@
make (intLen, marshalInt, unmarshalInt)
val (getSockOptBool, getIOCtlBool, setSockOptBool, _) =
make (boolLen, marshalBool, unmarshalBool)
- val (getSockOptTimeOpt, _, setSockOptTimeOpt, _) =
- make (timeOptLen, marshalTimeOpt, unmarshalTimeOpt)
+ val (getSockOptSize, getIOCtlSize, setSockOptSize, _) =
+ make (sizeLen, marshalSize, unmarshalSize)
+ val (getSockOptOptTime, getIOCtlOptTime, setSockOptOptTime, _) =
+ make (optTimeLen, marshalOptTime, unmarshalOptTime)
end
val getDEBUG = getSockOptBool (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_DEBUG)
@@ -201,16 +316,16 @@
val setKEEPALIVE = setSockOptBool (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_KEEPALIVE)
val getDONTROUTE = getSockOptBool (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_DONTROUTE)
val setDONTROUTE = setSockOptBool (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_DONTROUTE)
+ val getLINGER = getSockOptOptTime (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_LINGER)
+ val setLINGER = setSockOptOptTime (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_LINGER)
val getBROADCAST = getSockOptBool (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_BROADCAST)
- val getLINGER = getSockOptTimeOpt (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_LINGER)
- val setLINGER = setSockOptTimeOpt (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_LINGER)
val setBROADCAST = setSockOptBool (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_BROADCAST)
val getOOBINLINE = getSockOptBool (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_OOBINLINE)
val setOOBINLINE = setSockOptBool (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_OOBINLINE)
- val getSNDBUF = getSockOptInt (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_SNDBUF)
- val setSNDBUF = setSockOptInt (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_SNDBUF)
- val getRCVBUF = getSockOptInt (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_RCVBUF)
- val setRCVBUF = setSockOptInt (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_RCVBUF)
+ val getSNDBUF = getSockOptSize (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_SNDBUF)
+ val setSNDBUF = setSockOptSize (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_SNDBUF)
+ val getRCVBUF = getSockOptSize (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_RCVBUF)
+ val setRCVBUF = setSockOptSize (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_RCVBUF)
fun getTYPE s = getSockOptInt (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_TYPE) s
fun getERROR s =
let
@@ -218,10 +333,10 @@
in
if 0 = se
then NONE
- else SOME (Posix.Error.errorMsg se, SOME se)
+ else SOME (Posix.Error.errorMsg se, SOME se)
end handle Error.SysErr z => SOME z
local
- fun getName (s, f: sock * pre_sock_addr * C_Socklen.t ref -> int) =
+ fun getName (s, f: sock * pre_sock_addr * C_Socklen.t ref -> C_Int.int C_Errno.t) =
let
val (sa, salen, finish) = new_sock_addr ()
val () = Syscall.simple (fn () => f (s, sa, salen))
@@ -232,7 +347,7 @@
fun getPeerName s = getName (s, Prim.Ctl.getPeerName)
fun getSockName s = getName (s, Prim.Ctl.getSockName)
end
- val getNREAD = getIOCtlInt Prim.Ctl.FIONREAD
+ val getNREAD = getIOCtlSize Prim.Ctl.FIONREAD
val getATMARK = getIOCtlBool Prim.Ctl.SIOCATMARK
end
@@ -245,27 +360,24 @@
fun sameAddr (SA sa1, SA sa2) = sa1 = sa2
-fun familyOfAddr (SA sa) = NetHostDB.intToAddrFamily (Prim.familyOfAddr sa)
+fun familyOfAddr (SA sa) = Prim.familyOfAddr sa
fun bind (s, SA sa) =
Syscall.simple (fn () => Prim.bind (s, sa, C_Socklen.fromInt (Vector.length sa)))
fun listen (s, n) =
- Syscall.simple (fn () => Prim.listen (s, n))
+ Syscall.simple (fn () => Prim.listen (s, C_Int.fromInt n))
fun nonBlock' ({restart: bool},
- f : unit -> int, post : int -> 'a, again, no : 'a) =
+ errVal : ''a, f : unit -> ''a C_Errno.t, post : ''a -> 'b, again, no : 'b) =
Syscall.syscallErr
- ({clear = false, restart = restart},
- fn () => let val res = f ()
- in
- {return = res,
- post = fn () => post res,
- handlers = [(again, fn () => no)]}
- end)
+ ({clear = false, restart = restart, errVal = errVal}, fn () =>
+ {return = f (),
+ post = post,
+ handlers = [(again, fn () => no)]})
-fun nonBlock (f, post, no) =
- nonBlock' ({restart = true}, f, post, Error.again, no)
+fun nonBlock (errVal, f, post, no) =
+ nonBlock' ({restart = true}, errVal, f, post, Error.again, no)
local
structure PIO = PrimitiveFFI.Posix.IO
@@ -275,17 +387,15 @@
val fd = s
val flags =
Syscall.simpleResultRestart (fn () => PIO.fcntl2 (fd, PIO.F_GETFL))
- val _ =
- Syscall.simpleResultRestart
+ val () =
+ Syscall.simpleRestart
(fn () =>
PIO.fcntl3 (fd, PIO.F_SETFL,
- Word.toIntX
- (Word.orb (Word.fromInt flags,
- SysWord.fromInt PrimitiveFFI.Posix.FileSys.O.NONBLOCK))))
+ C_Int.orb (flags, PrimitiveFFI.Posix.FileSys.O.NONBLOCK)))
in
DynamicWind.wind
(f, fn () =>
- Syscall.simple (fn () => PIO.fcntl3 (fd, PIO.F_SETFL, flags)))
+ Syscall.simpleRestart (fn () => PIO.fcntl3 (fd, PIO.F_SETFL, flags)))
end
end
@@ -294,7 +404,7 @@
fun connectNB (s, SA sa) =
nonBlock'
- ({restart = false}, fn () =>
+ ({restart = false}, C_Int.fromInt ~1, fn () =>
withNonBlock (s, fn () => Prim.connect (s, sa, C_Socklen.fromInt (Vector.length sa))),
fn _ => true,
Error.inprogress, false)
@@ -312,7 +422,8 @@
val (sa, salen, finish) = new_sock_addr ()
in
nonBlock
- (fn () => withNonBlock (s, fn () => Prim.accept (s, sa, salen)),
+ (C_Int.fromInt ~1,
+ fn () => withNonBlock (s, fn () => Prim.accept (s, sa, salen)),
fn s => SOME (s, finish ()),
NONE)
end
@@ -380,25 +491,27 @@
type out_flags = {don't_route: bool, oob: bool}
-fun mk_out_flags {don't_route, oob} =
- Word.orb (if don't_route then Word.fromInt Prim.MSG_DONTROUTE else 0wx0,
- Word.orb (if oob then Word.fromInt Prim.MSG_OOB else 0wx0,
- 0wx0))
val no_out_flags = {don't_route = false, oob = false}
+fun mk_out_flags {don't_route, oob} =
+ C_Int.orb (if don't_route then Prim.MSG_DONTROUTE else 0x0,
+ C_Int.orb (if oob then Prim.MSG_OOB else 0x0,
+ 0x0))
+
local
- fun make (base, toPoly, primSend, primSendTo) =
+ fun make (base, primSend, primSendTo) =
let
val base = fn sl => let val (buf, i, sz) = base sl
- in (toPoly buf, i, sz)
+ in (buf, i, sz)
end
fun send' (s, sl, out_flags) =
let
val (buf, i, sz) = base sl
in
- Syscall.simpleResultRestart
- (fn () => primSend (s, buf, i, C_Size.fromInt sz,
- Word.toInt (mk_out_flags out_flags)))
+ (C_SSize.toInt o Syscall.simpleResultRestart')
+ ({errVal = C_SSize.fromInt ~1}, fn () =>
+ primSend (s, buf, C_Int.fromInt i, C_Size.fromInt sz,
+ mk_out_flags out_flags))
end
fun send (sock, buf) = send' (sock, buf, no_out_flags)
fun sendNB' (s, sl, out_flags) =
@@ -406,12 +519,11 @@
val (buf, i, sz) = base sl
in
nonBlock
- (fn () =>
- primSend (s, buf, i, C_Size.fromInt sz,
- Word.toInt (
- Word.orb (Word.fromInt Prim.MSG_DONTWAIT,
- mk_out_flags out_flags))),
- SOME,
+ (C_SSize.fromInt ~1,
+ fn () =>
+ primSend (s, buf, C_Int.fromInt i, C_Size.fromInt sz,
+ C_Int.orb (Prim.MSG_DONTWAIT, mk_out_flags out_flags)),
+ SOME o C_SSize.toInt,
NONE)
end
fun sendNB (sock, sl) = sendNB' (sock, sl, no_out_flags)
@@ -419,10 +531,10 @@
let
val (buf, i, sz) = base sl
in
- Syscall.simpleRestart
- (fn () =>
- primSendTo (s, buf, i, C_Size.fromInt sz,
- Word.toInt (mk_out_flags out_flags),
+ Syscall.simpleRestart'
+ ({errVal = C_SSize.fromInt ~1}, fn () =>
+ primSendTo (s, buf, C_Int.fromInt i, C_Size.fromInt sz,
+ mk_out_flags out_flags,
sa, C_Socklen.fromInt (Vector.length sa)))
end
fun sendTo (sock, sock_addr, sl) =
@@ -432,11 +544,10 @@
val (buf, i, sz) = base sl
in
nonBlock
- (fn () =>
- primSendTo (s, buf, i, C_Size.fromInt sz,
- Word.toInt (
- Word.orb (Word.fromInt Prim.MSG_DONTWAIT,
- mk_out_flags out_flags)),
+ (C_SSize.fromInt ~1,
+ fn () =>
+ primSendTo (s, buf, C_Int.fromInt i, C_Size.fromInt sz,
+ C_Int.orb (Prim.MSG_DONTWAIT, mk_out_flags out_flags),
sa, C_Socklen.fromInt (Vector.length sa)),
fn _ => true,
false)
@@ -449,12 +560,10 @@
in
val (sendArr, sendArr', sendArrNB, sendArrNB',
sendArrTo, sendArrTo', sendArrToNB, sendArrToNB') =
- make (Word8ArraySlice.base, Word8Array.toPoly,
- Prim.sendArr, Prim.sendArrTo)
+ make (Word8ArraySlice.base, Prim.sendArr, Prim.sendArrTo)
val (sendVec, sendVec', sendVecNB, sendVecNB',
sendVecTo, sendVecTo', sendVecToNB, sendVecToNB') =
- make (Word8VectorSlice.base, Word8Vector.toPoly,
- Prim.sendVec, Prim.sendVecTo)
+ make (Word8VectorSlice.base, Prim.sendVec, Prim.sendVecTo)
end
type in_flags = {peek: bool, oob: bool}
@@ -462,17 +571,18 @@
val no_in_flags = {peek = false, oob = false}
fun mk_in_flags {peek, oob} =
- Word.orb (if peek then Word.fromInt Prim.MSG_PEEK else 0wx0,
- Word.orb (if oob then Word.fromInt Prim.MSG_OOB else 0wx0,
- 0wx0))
+ C_Int.orb (if peek then Prim.MSG_PEEK else 0x0,
+ C_Int.orb (if oob then Prim.MSG_OOB else 0x0,
+ 0x0))
fun recvArr' (s, sl, in_flags) =
let
val (buf, i, sz) = Word8ArraySlice.base sl
in
- Syscall.simpleResultRestart
- (fn () => Prim.recv (s, Word8Array.toPoly buf, i, C_Size.fromInt sz,
- Word.toInt (mk_in_flags in_flags)))
+ (C_SSize.toInt o Syscall.simpleResultRestart')
+ ({errVal = C_SSize.fromInt ~1}, fn () =>
+ Prim.recv (s, Word8Array.toPoly buf, C_Int.fromInt i, C_Size.fromInt sz,
+ mk_in_flags in_flags))
end
fun getVec (a, n, bytesRead) =
@@ -482,7 +592,7 @@
fun recvVec' (sock, n, in_flags) =
let
- val a = Word8Array.rawArray n
+ val a = Word8Array.arrayUninit n
val bytesRead =
recvArr' (sock, Word8ArraySlice.full a, in_flags)
in
@@ -498,17 +608,18 @@
val (buf, i, sz) = Word8ArraySlice.base sl
val (sa, salen, finish) = new_sock_addr ()
val n =
- Syscall.simpleResultRestart
- (fn () => Prim.recvFrom (s, Word8Array.toPoly buf, i, C_Size.fromInt sz,
- Word.toInt (mk_in_flags in_flags),
- sa, salen))
+ (C_SSize.toInt o Syscall.simpleResultRestart')
+ ({errVal = C_SSize.fromInt ~1}, fn () =>
+ Prim.recvFrom (s, Word8Array.toPoly buf, C_Int.fromInt i, C_Size.fromInt sz,
+ mk_in_flags in_flags,
+ sa, salen))
in
(n, finish ())
end
fun recvVecFrom' (sock, n, in_flags) =
let
- val a = Word8Array.fromPoly (Primitive.Array.array n)
+ val a = Word8Array.arrayUninit n
val (bytesRead, sock_addr) =
recvArrFrom' (sock, Word8ArraySlice.full a, in_flags)
in
@@ -519,27 +630,29 @@
fun recvVecFrom (sock, n) = recvVecFrom' (sock, n, no_in_flags)
-fun mk_in_flagsNB z = Word.orb (mk_in_flags z, Word.fromInt Prim.MSG_DONTWAIT)
+fun mk_in_flagsNB in_flags = C_Int.orb (mk_in_flags in_flags, Prim.MSG_DONTWAIT)
fun recvArrNB' (s, sl, in_flags) =
let
val (buf, i, sz) = Word8ArraySlice.base sl
in
nonBlock
- (fn () => Prim.recv (s, Word8Array.toPoly buf, i, C_Size.fromInt sz,
- Word.toInt (mk_in_flagsNB in_flags)),
- SOME,
+ (C_SSize.fromInt ~1,
+ fn () => Prim.recv (s, Word8Array.toPoly buf, C_Int.fromInt i, C_Size.fromInt sz,
+ mk_in_flagsNB in_flags),
+ SOME o C_SSize.toInt,
NONE)
end
fun recvVecNB' (s, n, in_flags) =
let
- val a = Word8Array.rawArray n
+ val a = Word8Array.arrayUninit n
in
nonBlock
- (fn () => Prim.recv (s, Word8Array.toPoly a, 0, C_Size.fromInt n,
- Word.toInt (mk_in_flagsNB in_flags)),
- fn bytesRead => SOME (getVec (a, n, bytesRead)),
+ (C_SSize.fromInt ~1,
+ fn () => Prim.recv (s, Word8Array.toPoly a, 0, C_Size.fromInt n,
+ mk_in_flagsNB in_flags),
+ fn bytesRead => SOME (getVec (a, n, C_SSize.toInt bytesRead)),
NONE)
end
@@ -553,21 +666,23 @@
val (sa, salen, finish) = new_sock_addr ()
in
nonBlock
- (fn () => Prim.recvFrom (s, Word8Array.toPoly buf, i, C_Size.fromInt sz,
- Word.toInt (mk_in_flagsNB in_flags), sa, salen),
- fn n => SOME (n, finish ()),
+ (C_SSize.fromInt ~1,
+ fn () => Prim.recvFrom (s, Word8Array.toPoly buf, C_Int.fromInt i, C_Size.fromInt sz,
+ mk_in_flagsNB in_flags, sa, salen),
+ fn n => SOME (C_SSize.toInt n, finish ()),
NONE)
end
fun recvVecFromNB' (s, n, in_flags) =
let
- val a = Word8Array.fromPoly (Primitive.Array.array n)
+ val a = Word8Array.arrayUninit n
val (sa, salen, finish) = new_sock_addr ()
in
nonBlock
- (fn () => Prim.recvFrom (s, Word8Array.toPoly a, 0, C_Size.fromInt n,
- Word.toInt (mk_in_flagsNB in_flags), sa, salen),
- fn bytesRead => SOME (getVec (a, n, bytesRead), finish ()),
+ (C_SSize.fromInt ~1,
+ fn () => Prim.recvFrom (s, Word8Array.toPoly a, 0, C_Size.fromInt n,
+ mk_in_flagsNB in_flags, sa, salen),
+ fn bytesRead => SOME (getVec (a, n, C_SSize.toInt bytesRead), finish ()),
NONE)
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/net/unix-sock.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/net/unix-sock.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/net/unix-sock.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -14,7 +14,7 @@
type 'mode stream_sock = 'mode Socket.stream sock
type dgram_sock = Socket.dgram sock
type sock_addr = unix Socket.sock_addr
- val unixAF = NetHostDB.intToAddrFamily PrimitiveFFI.Socket.AF.UNIX
+ val unixAF = PrimitiveFFI.Socket.AF.UNIX
fun toAddr s =
let
@@ -29,7 +29,6 @@
fun fromAddr sa =
let
val sa = Socket.unpackSockAddr sa
- val sa = Word8Vector.toPoly sa
val len = Prim.pathLen sa
val a = CharArray.array (C_Size.toInt len, #"\000")
val _ = Prim.fromAddr (sa, CharArray.toPoly a, len)
@@ -40,13 +39,11 @@
structure Strm =
struct
fun socket () = GenericSock.socket (unixAF, Socket.SOCK.stream)
- fun socketPair () =
- GenericSock.socketPair (unixAF, Socket.SOCK.stream)
+ fun socketPair () = GenericSock.socketPair (unixAF, Socket.SOCK.stream)
end
structure DGrm =
struct
fun socket () = GenericSock.socket (unixAF, Socket.SOCK.dgram)
- fun socketPair () =
- GenericSock.socketPair (unixAF, Socket.SOCK.dgram)
+ fun socketPair () = GenericSock.socketPair (unixAF, Socket.SOCK.dgram)
end
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/posix/error.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/posix/error.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/posix/error.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -70,34 +70,63 @@
val restartFlag: bool ref
val syscallErr:
- {clear: bool, restart: bool} *
- (unit -> {return: int,
- post: unit -> 'a,
- handlers: (syserror * (unit -> 'a)) list}) -> 'a
+ {clear: bool, restart: bool, errVal: ''a} *
+ (unit -> {return: ''a C_Errno.t,
+ post: ''a -> 'b,
+ handlers: (syserror * (unit -> 'b)) list}) -> 'b
- (* clear = false, restart = false,
- * post = fn () => (), handlers = []
+ (* clear = false, restart = false, errVal = ~1
+ * post = fn _ => (), handlers = []
*)
- val simple: (unit -> int) -> unit
- (* clear = false, restart = true,
- * post = fn () => (), handlers = []
+ val simple: (unit -> C_Int.t C_Errno.t) -> unit
+ (* clear = false, restart = false,
+ * post = fn _ => (), handlers = []
*)
- val simpleRestart: (unit -> int) -> unit
- (* clear = false, restart = false,
- * post = fn () => return, handlers = []
+ val simple': {errVal: ''a} * (unit -> ''a C_Errno.t) -> unit
+
+ (* clear = false, restart = true, errVal = ~1
+ * post = fn _ => (), handlers = []
*)
- val simpleResult: (unit -> int) -> int
- (* clear = false, restart = true,
- * post = fn () => return, handlers = []
+ val simpleRestart: (unit -> C_Int.t C_Errno.t) -> unit
+ (* clear = false, restart = true,
+ * post = fn _ => (), handlers = []
*)
- val simpleResultRestart: (unit -> int) -> int
- (* clear = false, restart = false,
+ val simpleRestart': {errVal: ''a} * (unit -> ''a C_Errno.t) -> unit
+
+ (* clear = false, restart = false, errVal = ~1
+ * post = fn ret => ret, handlers = []
+ *)
+ val simpleResult: (unit -> C_Int.t C_Errno.t) -> C_Int.t
+ (* clear = false, restart = false,
+ * post = fn ret => ret, handlers = []
+ *)
+ val simpleResult': {errVal: ''a} * (unit -> ''a C_Errno.t) -> ''a
+
+ (* clear = false, restart = true, errVal = ~1
+ * post = fn ret => ret, handlers = []
+ *)
+ val simpleResultRestart: (unit -> C_Int.t C_Errno.t) -> C_Int.t
+ (* clear = false, restart = true,
+ * post = fn ret => ret, handlers = []
+ *)
+ val simpleResultRestart': {errVal: ''a} * (unit -> ''a C_Errno.t) -> ''a
+
+ (* clear = false, restart = false, errVal = ~1
* handlers = []
*)
- val syscall: (unit -> int * (unit -> 'a)) -> 'a
- (* clear = false, restart = true,
+ val syscall: (unit -> C_Int.t C_Errno.t * (C_Int.t -> 'a)) -> 'a
+ (* clear = false, restart = false,
* handlers = []
*)
- val syscallRestart: (unit -> int * (unit -> 'a)) -> 'a
+ val syscall': {errVal: ''a} * (unit -> ''a C_Errno.t * (''a -> 'b)) -> 'b
+
+ (* clear = false, restart = true, errVal = ~1
+ * handlers = []
+ *)
+ val syscallRestart: (unit -> C_Int.t C_Errno.t * (C_Int.t -> 'a)) -> 'a
+ (* clear = false, restart = true,
+ * handlers = []
+ *)
+ val syscallRestart': {errVal: ''a} * (unit -> ''a C_Errno.t * (''a -> 'b)) -> 'b
end
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/posix/error.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/posix/error.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/posix/error.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -178,8 +178,8 @@
exception SysErr of string * syserror option
- val toWord = SysWord.fromInt
- val fromWord = SysWord.toInt
+ val toWord = SysWord.fromLargeInt o C_Int.toLarge
+ val fromWord = C_Int.fromLarge o SysWord.toLargeInt
val cleared : syserror = 0
@@ -204,41 +204,43 @@
NONE => NONE
| SOME (n, _) => SOME n
- fun errorMsg (n: int) =
+ fun errorMsg (n: C_Int.t) =
let
val cs = strError n
in
- if cs = Primitive.Pointer.null
+ if Primitive.MLton.Pointer.isNull
+ (Primitive.MLton.Pointer.fromWord cs)
then "Unknown error"
- else COld.CS.toString cs
+ else CUtil.C_String.toString cs
end
fun raiseSys n = raise SysErr (errorMsg n, SOME n)
structure SysCall =
struct
- structure Thread = Primitive.Thread
+ structure Thread = Primitive.MLton.Thread
val blocker: (unit -> (unit -> unit)) ref =
ref (fn () => (fn () => ()))
(* ref (fn () => raise Fail "blocker not installed") *)
val restartFlag = ref true
- val syscallErr: {clear: bool, restart: bool} *
- (unit -> {return: int,
- post: unit -> 'a,
- handlers: (syserror * (unit -> 'a)) list}) -> 'a =
- fn ({clear, restart}, f) =>
+ val syscallErr: {clear: bool, restart: bool, errVal: ''a} *
+ (unit -> {return: ''a C_Errno.t,
+ post: ''a -> 'b,
+ handlers: (syserror * (unit -> 'b)) list}) -> 'b =
+ fn ({clear, restart, errVal}, f) =>
let
fun call (err: {errno: syserror,
- handlers: (syserror * (unit -> 'a)) list} -> 'a): 'a =
+ handlers: (syserror * (unit -> 'b)) list} -> 'b): 'b =
let
val () = Thread.atomicBegin ()
val () = if clear then clearErrno () else ()
val {return, post, handlers} =
f () handle exn => (Thread.atomicEnd (); raise exn)
+ val return = C_Errno.check return
in
- if ~1 = return
+ if errVal = return
then
(* Must getErrno () in the critical section. *)
let
@@ -247,24 +249,24 @@
in
err {errno = e, handlers = handlers}
end
- else DynamicWind.wind (post, Thread.atomicEnd)
+ else DynamicWind.wind (fn () => post return , Thread.atomicEnd)
end
- fun err {default: unit -> 'a,
+ fun err {default: unit -> 'b,
errno: syserror,
- handlers: (syserror * (unit -> 'a)) list}: 'a =
+ handlers: (syserror * (unit -> 'b)) list}: 'b =
case List.find (fn (e',_) => errno = e') handlers of
NONE => default ()
| SOME (_, handler) => handler ()
fun errBlocked {errno: syserror,
- handlers: (syserror * (unit -> 'a)) list}: 'a =
+ handlers: (syserror * (unit -> 'b)) list}: 'b =
err {default = fn () => raiseSys errno,
errno = errno, handlers = handlers}
fun errUnblocked
{errno: syserror,
- handlers: (syserror * (unit -> 'a)) list}: 'a =
+ handlers: (syserror * (unit -> 'b)) list}: 'b =
err {default = fn () =>
if restart andalso errno = intr andalso !restartFlag
- then if Thread.canHandle () = 0
+ then if Thread.canHandle () = 0w0
then call errUnblocked
else let val finish = !blocker ()
in
@@ -278,33 +280,49 @@
end
local
- val simpleResult' = fn ({restart}, f) =>
+ val simpleResultAux = fn ({restart, errVal}, f) =>
syscallErr
- ({clear = false, restart = restart}, fn () =>
+ ({clear = false, restart = restart, errVal = errVal}, fn () =>
let val return = f ()
- in {return = return, post = fn () => return, handlers = []}
+ in {return = return,
+ post = fn ret => ret,
+ handlers = []}
end)
in
val simpleResultRestart = fn f =>
- simpleResult' ({restart = true}, f)
+ simpleResultAux ({restart = true, errVal = C_Int.fromInt ~1}, f)
val simpleResult = fn f =>
- simpleResult' ({restart = false}, f)
+ simpleResultAux ({restart = false, errVal = C_Int.fromInt ~1}, f)
+
+ val simpleResultRestart' = fn ({errVal}, f) =>
+ simpleResultAux ({restart = true, errVal = errVal}, f)
+ val simpleResult' = fn ({errVal}, f) =>
+ simpleResultAux ({restart = false, errVal = errVal}, f)
end
val simpleRestart = ignore o simpleResultRestart
val simple = ignore o simpleResult
- val syscallRestart = fn f =>
+ val simpleRestart' = fn ({errVal}, f) =>
+ ignore (simpleResultRestart' ({errVal = errVal}, f))
+ val simple' = fn ({errVal}, f) =>
+ ignore (simpleResult' ({errVal = errVal}, f))
+
+ val syscallRestart' = fn ({errVal}, f) =>
syscallErr
- ({clear = false, restart = true}, fn () =>
+ ({clear = false, restart = true, errVal = errVal}, fn () =>
let val (return, post) = f ()
in {return = return, post = post, handlers = []}
end)
- val syscall = fn f =>
+ val syscall' = fn ({errVal}, f) =>
syscallErr
- ({clear = false, restart = false}, fn () =>
+ ({clear = false, restart = false, errVal = errVal}, fn () =>
let val (return, post) = f ()
in {return = return, post = post, handlers = []}
end)
+ val syscallRestart = fn f =>
+ syscallRestart' ({errVal = C_Int.fromInt ~1}, f)
+ val syscall = fn f =>
+ syscall' ({errVal = C_Int.fromInt ~1}, f)
end
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/posix/file-sys.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/posix/file-sys.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/posix/file-sys.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -124,5 +124,5 @@
sig
include POSIX_FILE_SYS
- val wordToOpenMode: SysWord.word -> open_mode
+ val flagsToOpenMode: O.flags -> open_mode
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/posix/file-sys.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/posix/file-sys.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/posix/file-sys.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -10,34 +10,33 @@
struct
structure Error = PosixError
- (* Patch to make Time look like it deals with Int.int
+ (* Patch to make Time look like it deals with C_Time.t
* instead of LargeInt.int.
*)
structure Time =
struct
open Time
- val fromSeconds = fromSeconds o LargeInt.fromInt
+ val fromSeconds = fromSeconds o C_Time.toLarge
fun toSeconds t =
- LargeInt.toInt (Time.toSeconds t)
+ C_Time.fromLarge (Time.toSeconds t)
handle Overflow => Error.raiseSys Error.inval
end
-
+
structure SysCall = Error.SysCall
structure Prim = PrimitiveFFI.Posix.FileSys
open Prim
structure Stat = Prim.Stat
- structure Flags = BitFlags
type file_desc = C_Fd.t
type uid = C_UId.t
type gid = C_GId.t
- val fdToWord = Primitive.FileDesc.toWord
- val wordToFD = Primitive.FileDesc.fromWord
- val fdToIOD = OS.IO.fromFD
- val iodToFD = SOME o OS.IO.toFD
+ val fdToWord = C_Fd.toSysWord
+ val wordToFD = C_Fd.fromSysWord
+ val fdToIOD = fn x => x
+ val iodToFD = SOME o (fn x => x)
(*------------------------------------*)
(* dirstream *)
@@ -58,15 +57,10 @@
let
val s = NullString.nullTerm s
in
- SysCall.syscall
- (fn () =>
- let
- val d = Prim.openDir s
- val p = Primitive.Pointer.fromWord d
- in
- (if Primitive.Pointer.isNull p then ~1 else 0,
- fn () => DS (ref (SOME d)))
- end)
+ SysCall.syscall'
+ ({errVal = C_DirP.fromWord 0w0}, fn () =>
+ (Prim.openDir s, fn d =>
+ DS (ref (SOME d))))
end
fun readdir d =
@@ -76,31 +70,25 @@
let
val res =
SysCall.syscallErr
- ({clear = true, restart = false},
- fn () =>
- let
- val cs = Prim.readDir d
- in
- {return = if Primitive.Pointer.isNull cs
- then ~1
- else 0,
- post = fn () => SOME cs,
- handlers = [(Error.cleared, fn () => NONE),
- (* MinGW sets errno to ENOENT when it
- * returns NULL.
- *)
- (Error.noent, fn () => NONE)]}
- end)
+ ({clear = true, restart = false,
+ errVal = CUtil.C_Pointer.null}, fn () =>
+ {return = Prim.readDir d,
+ post = fn cs => SOME cs,
+ handlers = [(Error.cleared, fn () => NONE),
+ (* MinGW sets errno to ENOENT when it
+ * returns NULL.
+ *)
+ (Error.noent, fn () => NONE)]})
in
case res of
NONE => NONE
| SOME cs =>
let
- val s = COld.CS.toString cs
+ val s = CUtil.C_String.toString cs
in
if s = "." orelse s = ".."
then loop ()
- else SOME s
+ else SOME s
end
end
in loop ()
@@ -108,16 +96,7 @@
fun rewinddir d =
let val d = get d
- in
- SysCall.syscallErr
- ({clear = true, restart = false},
- fn () =>
- let val () = Prim.rewindDir d
- in
- {return = ~1,
- post = fn () => (),
- handlers = [(Error.cleared, fn () => ())]}
- end)
+ in Prim.rewindDir d
end
fun closedir (DS r) =
@@ -131,7 +110,7 @@
local
val size: int ref = ref 1
- fun make () = Primitive.Array.array (!size)
+ fun make () = Array.arrayUninit (!size)
val buffer = ref (make ())
fun extractToChar (a, c) =
@@ -140,7 +119,7 @@
(* find the null terminator *)
fun loop i =
if i >= n
- then raise Fail "String.extractFromC didn't find terminator"
+ then raise Fail "extractToChar didn't find terminator"
else if c = Array.sub (a, i)
then i
else loop (i + 1)
@@ -151,21 +130,30 @@
fun extract a = extractToChar (a, #"\000")
in
fun getcwd () =
- if Primitive.Pointer.isNull (Prim.getcwd (!buffer, C_Size.fromInt (!size)))
- then (size := 2 * !size
- ; buffer := make ()
- ; getcwd ())
- else extract (!buffer)
+ let
+ val res =
+ SysCall.syscallErr
+ ({clear = false, restart = false,
+ errVal = CUtil.C_Pointer.null}, fn () =>
+ {return = Prim.getcwd (!buffer, C_Size.fromInt (!size)),
+ post = fn _ => true,
+ handlers = [(Error.range, fn _ => false)]})
+ in
+ if res
+ then extract (!buffer)
+ else (size := 2 * !size
+ ; buffer := make ()
+ ; getcwd ())
+ end
end
- val FD = Primitive.FileDesc.fromInt
+ val stdin : C_Fd.t = 0
+ val stdout : C_Fd.t = 1
+ val stderr : C_Fd.t = 2
- val stdin = FD 0
- val stdout = FD 1
- val stderr = FD 2
-
structure S =
struct
+ structure Flags = BitFlags(structure S = C_Mode)
open S Flags
type mode = C_Mode.t
val ifblk = IFBLK
@@ -195,32 +183,33 @@
structure O =
struct
+ structure Flags = BitFlags(structure S = C_Int)
open O Flags
- val append = SysWord.fromInt APPEND
- val binary = SysWord.fromInt BINARY
- val creat = SysWord.fromInt CREAT
- val dsync = SysWord.fromInt DSYNC
- val excl = SysWord.fromInt EXCL
- val noctty = SysWord.fromInt NOCTTY
- val nonblock = SysWord.fromInt NONBLOCK
- val rdonly = SysWord.fromInt RDONLY
- val rdwr = SysWord.fromInt RDWR
- val rsync = SysWord.fromInt RSYNC
- val sync = SysWord.fromInt SYNC
- val text = SysWord.fromInt TEXT
- val trunc = SysWord.fromInt TRUNC
- val wronly = SysWord.fromInt WRONLY
+ val append = APPEND
+ val binary = BINARY
+ val creat = CREAT
+ val dsync = DSYNC
+ val excl = EXCL
+ val noctty = NOCTTY
+ val nonblock = NONBLOCK
+ val rdonly = RDONLY
+ val rdwr = RDWR
+ val rsync = RSYNC
+ val sync = SYNC
+ val text = TEXT
+ val trunc = TRUNC
+ val wronly = WRONLY
end
datatype open_mode = O_RDONLY | O_WRONLY | O_RDWR
- fun wordToOpenMode w =
- if w = O.rdonly then O_RDONLY
- else if w = O.wronly then O_WRONLY
- else if w = O.rdwr then O_RDWR
- else raise Fail "wordToOpenMode: unknown word"
+ fun flagsToOpenMode f =
+ if f = O.rdonly then O_RDONLY
+ else if f = O.wronly then O_WRONLY
+ else if f = O.rdwr then O_RDWR
+ else raise Fail "flagsToOpenMode: unknown flag"
- val openModeToWord =
+ val openModeToFlags =
fn O_RDONLY => O.rdonly
| O_WRONLY => O.wronly
| O_RDWR => O.rdwr
@@ -228,24 +217,27 @@
fun createf (pathname, openMode, flags, mode) =
let
val pathname = NullString.nullTerm pathname
- val flags = Flags.flags [openModeToWord openMode,
- flags,
- O.creat]
+ val flags = O.Flags.flags [openModeToFlags openMode,
+ flags,
+ O.creat]
+ val flags = C_Int.fromSysWord (O.Flags.toWord flags)
val fd =
SysCall.simpleResult
- (fn () => Prim.open3 (pathname, SysWord.toInt flags, mode))
+ (fn () => Prim.open3 (pathname, flags, mode))
in
- FD fd
+ fd
end
fun openf (pathname, openMode, flags) =
let
val pathname = NullString.nullTerm pathname
- val flags = Flags.flags [openModeToWord openMode, flags]
+ val flags = O.Flags.flags [openModeToFlags openMode, flags]
+ val flags = C_Int.fromSysWord (O.Flags.toWord flags)
val fd =
SysCall.simpleResult
- (fn () => Prim.open3 (pathname, SysWord.toInt flags, Flags.empty))
- in FD fd
+ (fn () => Prim.open3 (pathname, flags, C_Mode.fromInt 0))
+ in
+ fd
end
fun creat (s, m) = createf (s, O_WRONLY, O.trunc, m)
@@ -283,13 +275,10 @@
let
val path = NullString.nullTerm path
in
- SysCall.syscall
- (fn () =>
- let val len = Prim.readlink (path, buf, C_Size.fromInt size)
- in
- (len, fn () =>
- ArraySlice.vector (ArraySlice.slice (buf, 0, SOME len)))
- end)
+ SysCall.syscall'
+ ({errVal = C_SSize.fromInt ~1}, fn () =>
+ (Prim.readlink (path, buf, C_Size.fromInt size), fn len =>
+ ArraySlice.vector (ArraySlice.slice (buf, 0, SOME (C_SSize.toInt len)))))
end
end
@@ -357,7 +346,7 @@
local
fun make prim arg =
- SysCall.syscall (fn () => (prim arg, fn () => ST.fromC ()))
+ SysCall.syscall (fn () => (prim arg, fn _ => ST.fromC ()))
in
val stat = (make Prim.Stat.stat) o NullString.nullTerm
val lstat = (make Prim.Stat.lstat) o NullString.nullTerm
@@ -373,23 +362,19 @@
fun access (path: string, mode: access_mode list): bool =
let
- val mode = SysWord.toInt (Flags.flags (map SysWord.fromInt (A.F_OK :: (map conv_access_mode mode))))
+ val mode = List.foldl C_Int.orb 0 (A.F_OK :: (map conv_access_mode mode))
val path = NullString.nullTerm path
in
SysCall.syscallErr
- ({clear = false, restart = false},
- fn () =>
- let val return = Prim.access (path, mode)
- in
- {return = return,
- post = fn () => true,
- handlers = [(Error.acces, fn () => false),
- (Error.loop, fn () => false),
- (Error.nametoolong, fn () => false),
- (Error.noent, fn () => false),
- (Error.notdir, fn () => false),
- (Error.rofs, fn () => false)]}
- end)
+ ({clear = false, restart = false, errVal = C_Int.fromInt ~1}, fn () =>
+ {return = Prim.access (path, mode),
+ post = fn _ => true,
+ handlers = [(Error.acces, fn () => false),
+ (Error.loop, fn () => false),
+ (Error.nametoolong, fn () => false),
+ (Error.noent, fn () => false),
+ (Error.notdir, fn () => false),
+ (Error.rofs, fn () => false)]})
end
local
@@ -412,7 +397,7 @@
(fn () =>
(U.setAcTime a
; U.setModTime m
- ; (U.utime f, fn () =>
+ ; (U.utime f, fn _ =>
())))
end
end
@@ -452,18 +437,12 @@
fun make prim (f, s) =
SysCall.syscallErr
- ({clear = true, restart = false},
- fn () =>
- let
- val return = prim (f, convertProperty s)
- in
- {return = return,
- post = fn () => SOME (SysWord.fromInt return),
- handlers = [(Error.cleared, fn () => NONE)]}
- end)
+ ({clear = true, restart = false, errVal = C_Long.fromInt ~1}, fn () =>
+ {return = prim (f, convertProperty s),
+ post = fn ret => SOME (SysWord.fromLargeInt (C_Long.toLarge ret)),
+ handlers = [(Error.cleared, fn () => NONE)]})
in
- val pathconf =
- make (fn (path, s) => Prim.pathconf (NullString.nullTerm path, s))
+ val pathconf = make (fn (path, s) => Prim.pathconf (NullString.nullTerm path, s))
val fpathconf = make Prim.fpathconf
end
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/posix/flags.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/posix/flags.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/posix/flags.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -1,3 +1,11 @@
+(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
+ * Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ *)
+
signature BIT_FLAGS =
sig
eqtype flags
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/posix/flags.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/posix/flags.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/posix/flags.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -6,25 +6,30 @@
* See the file MLton-LICENSE for details.
*)
-functor BitFlags(val all: SysWord.word): BIT_FLAGS_EXTRA =
+functor BitFlags(structure S : sig
+ eqtype t
+ val toSysWord: t -> SysWord.word
+ val fromSysWord: SysWord.word -> t
+ val andb: t * t -> t
+ val notb: t -> t
+ val orb: t * t -> t
+ end): BIT_FLAGS_EXTRA =
struct
- type flags = SysWord.word
+ type flags = S.t
- val all: flags = all
- val empty: flags = 0w0
+ val all: flags = S.fromSysWord (SysWord.~ 0w1)
+ val empty: flags = S.fromSysWord 0w0
- fun toWord f = f
- fun fromWord f = SysWord.andb(f, all)
+ fun toWord f = S.toSysWord f
+ fun fromWord w = S.fromSysWord (SysWord.andb (w, toWord all))
- val flags: flags list -> flags = List.foldl SysWord.orb empty
+ val flags: flags list -> flags = List.foldl S.orb empty
- val intersect: flags list -> flags = List.foldl SysWord.andb all
+ val intersect: flags list -> flags = List.foldl S.andb all
- fun clear(f, f') = SysWord.andb(SysWord.notb f, f')
+ fun clear (f, f') = S.andb (S.notb f, f')
- fun allSet(f, f') = SysWord.andb(f, f') = f
+ fun allSet (f, f') = S.andb (f, f') = f'
- fun anySet(f, f') = SysWord.andb(f, f') <> 0w0
-
+ fun anySet (f, f') = S.andb (f, f') <> empty
end
-structure BitFlags = BitFlags(val all = 0wxFFFF: SysWord.word)
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/posix/io.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/posix/io.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/posix/io.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -15,24 +15,21 @@
structure SysCall = Error.SysCall
structure FS = PosixFileSys
-type file_desc = C_Fd.t
+type file_desc = C_Fd.t (* = C_Int.t *)
type pid = C_PId.t
-val FD = C_Fd.fromInt
-val unFD = C_Fd.toInt
-
local
- val a: file_desc array = Array.array (2, FD 0)
+ val a: file_desc array = Array.array (2, C_Fd.fromInt 0)
in
fun pipe () =
SysCall.syscall
(fn () =>
(Prim.pipe a,
- fn () => {infd = Array.sub (a, 0),
- outfd = Array.sub (a, 1)}))
+ fn _ => {infd = Array.sub (a, 0),
+ outfd = Array.sub (a, 1)}))
end
-fun dup fd = FD (SysCall.simpleResult (fn () => Prim.dup fd))
+fun dup fd = SysCall.simpleResult (fn () => Prim.dup fd)
fun dup2 {new, old} = SysCall.simple (fn () => Prim.dup2 (old, new))
@@ -40,8 +37,9 @@
structure FD =
struct
- open FD BitFlags
- val cloexec = SysWord.fromInt CLOEXEC
+ structure Flags = BitFlags(structure S = C_Int)
+ open FD Flags
+ val cloexec = CLOEXEC
end
structure O = PosixFileSys.O
@@ -49,30 +47,28 @@
datatype open_mode = datatype PosixFileSys.open_mode
fun dupfd {base, old} =
- FD (SysCall.simpleResultRestart
- (fn () => Prim.fcntl3 (old, F_DUPFD, unFD base)))
+ SysCall.simpleResultRestart
+ (fn () => Prim.fcntl3 (old, F_DUPFD, base))
fun getfd fd =
- Word.fromInt (SysCall.simpleResultRestart
- (fn () => Prim.fcntl2 (fd, F_GETFD)))
+ SysCall.simpleResultRestart
+ (fn () => Prim.fcntl2 (fd, F_GETFD))
fun setfd (fd, flags): unit =
SysCall.simpleRestart
- (fn () => Prim.fcntl3 (fd, F_SETFD, Word.toIntX flags))
+ (fn () => Prim.fcntl3 (fd, F_SETFD, flags))
fun getfl fd : O.flags * open_mode =
let
- val n =
- SysCall.simpleResultRestart (fn () => Prim.fcntl2 (fd, F_GETFL))
- val w = Word.fromInt n
- val flags = Word.andb (w, Word.notb (Word.fromInt O_ACCMODE))
- val mode = Word.andb (w, (Word.fromInt O_ACCMODE))
- in (flags, PosixFileSys.wordToOpenMode mode)
+ val n = SysCall.simpleResultRestart (fn () => Prim.fcntl2 (fd, F_GETFL))
+ val flags = C_Int.andb (n, C_Int.notb O_ACCMODE)
+ val mode = C_Int.andb (n, O_ACCMODE)
+ in (flags, PosixFileSys.flagsToOpenMode mode)
end
fun setfl (fd, flags: O.flags): unit =
SysCall.simpleRestart
- (fn () => Prim.fcntl3 (fd, F_SETFL, Word.toIntX flags))
+ (fn () => Prim.fcntl3 (fd, F_SETFL, flags))
datatype whence = SEEK_SET | SEEK_CUR | SEEK_END
@@ -82,11 +78,9 @@
| SEEK_END => Prim.SEEK_END
fun lseek (fd, n: Position.int, w: whence): Position.int =
- SysCall.syscall
- (fn () =>
- let val n = Prim.lseek (fd, n, whenceToInt w)
- in (if n = ~1 then ~1 else 0, fn () => n)
- end)
+ SysCall.simpleResult'
+ ({errVal = C_Off.fromInt ~1}, fn () =>
+ Prim.lseek (fd, n, whenceToInt w))
fun fsync fd : unit = SysCall.simple (fn () => Prim.fsync fd)
@@ -99,15 +93,12 @@
if n = Prim.FLock.SEEK_SET
then SEEK_SET
else if n = Prim.FLock.SEEK_CUR
- then SEEK_CUR
- else if n = Prim.FLock.SEEK_END
- then SEEK_END
- else raise Fail "Posix.IO.intToWhence"
+ then SEEK_CUR
+ else if n = Prim.FLock.SEEK_END
+ then SEEK_END
+ else raise Fail "Posix.IO.intToWhence"
-datatype lock_type =
- F_RDLCK
- | F_WRLCK
- | F_UNLCK
+datatype lock_type = F_RDLCK | F_WRLCK | F_UNLCK
val lockTypeToInt =
fn F_RDLCK => Prim.FLock.F_RDLCK
@@ -118,10 +109,10 @@
if n = Prim.FLock.F_RDLCK
then F_RDLCK
else if n = Prim.FLock.F_WRLCK
- then F_WRLCK
- else if n = Prim.FLock.F_UNLCK
- then F_UNLCK
- else raise Fail "Posix.IO.intToLockType"
+ then F_WRLCK
+ else if n = Prim.FLock.F_UNLCK
+ then F_UNLCK
+ else raise Fail "Posix.IO.intToLockType"
structure FLock =
struct
@@ -153,7 +144,7 @@
; P.setWhence (whenceToInt whence)
; P.setStart start
; P.setLen len
- ; P.fcntl (fd, cmd)), fn () =>
+ ; P.fcntl (fd, cmd)), fn _ =>
{ltype = intToLockType (P.getType ()),
whence = intToWhence (P.getWhence ()),
start = P.getStart (),
@@ -210,9 +201,12 @@
endPos = NONE,
verifyPos = NONE}
- fun make {RD, WR, fromVector, read, setMode, toArraySlice, toVectorSlice,
- vectorLength, write, writeVec} =
+ fun make {RD, WR, fromVector, readArr, setMode, toArraySlice, toVectorSlice,
+ vectorLength, writeArr, writeVec} =
let
+ val primReadArr = readArr
+ val primWriteArr = writeArr
+ val primWriteVec = writeVec
val setMode =
fn fd =>
if let
@@ -227,35 +221,49 @@
fun readArr (fd, sl): int =
let
val (buf, i, sz) = ArraySlice.base (toArraySlice sl)
+ val bytesRead =
+ SysCall.simpleResultRestart'
+ ({errVal = C_SSize.fromInt ~1}, fn () =>
+ primReadArr (fd, buf, C_Int.fromInt i, C_Size.fromInt sz))
+ val bytesRead = C_SSize.toInt bytesRead
in
- SysCall.simpleResultRestart (fn () => read (fd, buf, i, C_Size.fromInt sz))
+ bytesRead
end
fun readVec (fd, n) =
let
- val a = Primitive.Array.array n
+ val buf = Array.arrayUninit n
val bytesRead =
- SysCall.simpleResultRestart (fn () => read (fd, a, 0, C_Size.fromInt n))
+ SysCall.simpleResultRestart'
+ ({errVal = C_SSize.fromInt ~1}, fn () =>
+ primReadArr (fd, buf, C_Int.fromInt 0, C_Size.fromInt n))
+ val bytesRead = C_SSize.toInt bytesRead
in
fromVector
(if n = bytesRead
- then Vector.fromArray a
- else ArraySlice.vector (ArraySlice.slice
- (a, 0, SOME bytesRead)))
+ then Vector.fromArray buf
+ else ArraySlice.vector (ArraySlice.slice (buf, 0, SOME bytesRead)))
end
- fun writeArr (fd, sl) =
+ fun writeArr (fd, sl): int =
let
val (buf, i, sz) = ArraySlice.base (toArraySlice sl)
+ val bytesWrote =
+ SysCall.simpleResultRestart'
+ ({errVal = C_SSize.fromInt ~1}, fn () =>
+ primWriteArr (fd, buf, C_Int.fromInt i, C_Size.fromInt sz))
+ val bytesWrote = C_SSize.toInt bytesWrote
in
- SysCall.simpleResultRestart
- (fn () => write (fd, buf, i, C_Size.fromInt sz))
+ bytesWrote
end
- val writeVec =
- fn (fd, sl) =>
+ fun writeVec (fd, sl): int =
let
val (buf, i, sz) = VectorSlice.base (toVectorSlice sl)
+ val bytesWrote =
+ SysCall.simpleResultRestart'
+ ({errVal = C_SSize.fromInt ~1}, fn () =>
+ primWriteVec (fd, buf, C_Int.fromInt i, C_Size.fromInt sz))
+ val bytesWrote = C_SSize.toInt bytesWrote
in
- SysCall.simpleResultRestart
- (fn () => writeVec (fd, buf, i, C_Size.fromInt sz))
+ bytesWrote
end
fun mkReader {fd, name, initBlkMode} =
let
@@ -304,7 +312,7 @@
RD {avail = avail,
block = NONE,
canInput = NONE,
- chunkSize = Primitive.TextIO.bufSize,
+ chunkSize = Int32.toInt Primitive.Controls.bufSize,
close = close,
endPos = endPos,
getPos = getPos,
@@ -378,23 +386,23 @@
make {RD = BinPrimIO.RD,
WR = BinPrimIO.WR,
fromVector = Word8Vector.fromPoly,
- read = readWord8,
+ readArr = readWord8,
setMode = Prim.setbin,
toArraySlice = Word8ArraySlice.toPoly,
toVectorSlice = Word8VectorSlice.toPoly,
vectorLength = Word8Vector.length,
- write = writeWord8Arr,
+ writeArr = writeWord8Arr,
writeVec = writeWord8Vec}
val {mkReader = mkTextReader, mkWriter = mkTextWriter, ...} =
make {RD = TextPrimIO.RD,
WR = TextPrimIO.WR,
fromVector = fn v => v,
- read = readChar8,
+ readArr = readChar8,
setMode = Prim.settext,
toArraySlice = CharArraySlice.toPoly,
toVectorSlice = CharVectorSlice.toPoly,
vectorLength = CharVector.length,
- write = writeChar8Arr,
+ writeArr = writeChar8Arr,
writeVec = writeChar8Vec}
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/posix/posix.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/posix/posix.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/posix/posix.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -9,8 +9,7 @@
structure SysDB: POSIX_SYS_DB
structure TTY: POSIX_TTY
- sharing type FileSys.file_desc = ProcEnv.file_desc = IO.file_desc
- = TTY.file_desc
+ sharing type FileSys.file_desc = ProcEnv.file_desc = IO.file_desc = TTY.file_desc
sharing type ProcEnv.gid = FileSys.gid = SysDB.gid
sharing type FileSys.open_mode = IO.open_mode
sharing type Process.pid = ProcEnv.pid = IO.pid = TTY.pid
@@ -29,8 +28,7 @@
structure SysDB: POSIX_SYS_DB
structure TTY: POSIX_TTY
- sharing type FileSys.file_desc = ProcEnv.file_desc = IO.file_desc
- = TTY.file_desc
+ sharing type FileSys.file_desc = ProcEnv.file_desc = IO.file_desc = TTY.file_desc
sharing type ProcEnv.gid = FileSys.gid = SysDB.gid
sharing type FileSys.open_mode = IO.open_mode
sharing type Process.pid = ProcEnv.pid = IO.pid = TTY.pid
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/posix/proc-env.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/posix/proc-env.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/posix/proc-env.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -11,7 +11,8 @@
structure Prim = PrimitiveFFI.Posix.ProcEnv
structure Error = PosixError
structure SysCall = Error.SysCall
- structure CS = COld.CS
+ structure CS = CUtil.C_String
+ structure CSS = CUtil.C_StringArray
type pid = C_PId.t
type uid = C_UId.t
@@ -34,31 +35,27 @@
fun setsid () = SysCall.simpleResult (Prim.setsid)
- fun id x = x
- val uidToWord = id
- val wordToUid = id
- val gidToWord = id
- val wordToGid = id
+ val uidToWord = SysWord.fromLarge o C_UId.toLarge
+ val wordToUid = C_UId.fromLarge o SysWord.toLarge
+ val gidToWord = SysWord.fromLarge o C_GId.toLarge
+ val wordToGid = C_GId.fromLarge o SysWord.toLarge
- local
- val n = Prim.getgroupsN ()
- val a: word array = Primitive.Array.array n
- in
- fun getgroups () =
- SysCall.syscall
- (fn () =>
- let val n = Prim.getgroups (n, a)
- in (n, fn () =>
- ArraySlice.toList (ArraySlice.slice (a, 0, SOME n)))
- end)
- end
+ fun getgroups () =
+ SysCall.syscall
+ (fn () =>
+ let
+ val n = Prim.getgroupsN ()
+ val a: C_GId.t array = Array.arrayUninit (C_Int.toInt n)
+ in
+ (Prim.getgroups (n, a), fn n =>
+ ArraySlice.toList (ArraySlice.slice (a, 0, SOME (C_Int.toInt n))))
+ end)
fun getlogin () =
- let val cs = Prim.getlogin ()
- in if Primitive.Pointer.isNull cs
- then raise (Error.SysErr ("no login name", NONE))
- else CS.toString cs
- end
+ SysCall.syscall'
+ ({errVal = CUtil.C_Pointer.null}, fn () =>
+ (Prim.getlogin (), fn cs =>
+ CS.toString cs))
fun setpgid {pid, pgid} =
let
@@ -72,7 +69,7 @@
fun uname () =
SysCall.syscall
(fn () =>
- (Prim.uname (), fn () =>
+ (Prim.uname (), fn _ =>
[("sysname", CS.toString (Prim.Uname.getSysName ())),
("nodename", CS.toString (Prim.Uname.getNodeName ())),
("release", CS.toString (Prim.Uname.getRelease ())),
@@ -123,7 +120,7 @@
(Prim.SC_GETPW_R_SIZE_MAX,"GETPW_R_SIZE_MAX"),
(Prim.SC_HOST_NAME_MAX,"HOST_NAME_MAX"),
(Prim.SC_IOV_MAX,"IOV_MAX"),
- (Prim.SC_IPV6,"IPV6"),
+ (* (Prim.SC_IPV6,"IPV6"), *)
(Prim.SC_JOB_CONTROL,"JOB_CONTROL"),
(Prim.SC_LINE_MAX,"LINE_MAX"),
(Prim.SC_LOGIN_NAME_MAX,"LOGIN_NAME_MAX"),
@@ -141,7 +138,7 @@
(Prim.SC_PAGE_SIZE,"PAGE_SIZE"),
(Prim.SC_PRIORITIZED_IO,"PRIORITIZED_IO"),
(Prim.SC_PRIORITY_SCHEDULING,"PRIORITY_SCHEDULING"),
- (Prim.SC_RAW_SOCKETS,"RAW_SOCKETS"),
+ (* (Prim.SC_RAW_SOCKETS,"RAW_SOCKETS"), *)
(Prim.SC_READER_WRITER_LOCKS,"READER_WRITER_LOCKS"),
(Prim.SC_REALTIME_SIGNALS,"REALTIME_SIGNALS"),
(Prim.SC_REGEXP,"REGEXP"),
@@ -213,14 +210,14 @@
case List.find (fn (_, s') => s = s') sysconfNames of
NONE => Error.raiseSys Error.inval
| SOME (n, _) =>
- (SysWord.fromInt o SysCall.simpleResult)
- (fn () => Prim.sysconf n)
+ (SysWord.fromLargeInt o C_Long.toLarge o SysCall.simpleResult')
+ ({errVal = C_Long.fromInt ~1}, fn () => Prim.sysconf n)
end
local
structure Times = Prim.Times
- val ticksPerSec = Int.toLarge (SysWord.toIntX (sysconf "CLK_TCK"))
+ val ticksPerSec = SysWord.toLargeIntX (sysconf "CLK_TCK")
fun cvt (ticks: C_Clock.t) =
Time.fromTicks (LargeInt.quot
@@ -229,25 +226,23 @@
ticksPerSec))
in
fun times () =
- SysCall.syscall
- (fn () =>
- let val elapsed = Prim.times ()
- in (0, fn () =>
- {elapsed = cvt elapsed,
- utime = cvt (Times.getUTime ()),
- stime = cvt (Times.getSTime ()),
- cutime = cvt (Times.getCUTime ()),
- cstime = cvt (Times.getCSTime ())})
- end)
+ SysCall.syscall'
+ ({errVal = C_Clock.fromInt ~1}, fn () =>
+ (Prim.times (), fn elapsed =>
+ {elapsed = cvt elapsed,
+ utime = cvt (Times.getUTime ()),
+ stime = cvt (Times.getSTime ()),
+ cutime = cvt (Times.getCUTime ()),
+ cstime = cvt (Times.getCSTime ())}))
end
- fun environ () = COld.CSS.toList (Prim.environGet ())
+ fun environ () = CSS.toList (Prim.environGet ())
fun getenv name =
let
val cs = Prim.getenv (NullString.nullTerm name)
in
- if Primitive.Pointer.isNull cs
+ if CUtil.C_Pointer.isNull cs
then NONE
else SOME (CS.toString cs)
end
@@ -257,11 +252,8 @@
fun isatty fd = Prim.isatty fd
fun ttyname fd =
- SysCall.syscall
- (fn () =>
- let val cs = Prim.ttyname fd
- in
- (if Primitive.Pointer.isNull cs then ~1 else 0,
- fn () => CS.toString cs)
- end)
+ SysCall.syscall'
+ ({errVal = CUtil.C_Pointer.null}, fn () =>
+ (Prim.ttyname fd, fn cs =>
+ CS.toString cs))
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/posix/process.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/posix/process.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/posix/process.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -14,19 +14,16 @@
structure SysCall = Error.SysCall
type signal = PosixSignal.signal
- type pid = Pid.t
+ type pid = C_PId.t
- val wordToPid = Pid.fromInt o SysWord.toInt
- val pidToWord = SysWord.fromInt o Pid.toInt
+ val wordToPid = C_PId.fromSysWord
+ val pidToWord = C_PId.toSysWord
fun fork () =
- SysCall.syscall
- (fn () =>
- let
- val p = Prim.fork ()
- val p' = Pid.toInt p
- in (p', fn () => if p' = 0 then NONE else SOME p)
- end)
+ SysCall.syscall'
+ ({errVal = C_PId.fromInt ~1}, fn () =>
+ (Prim.fork (), fn p =>
+ if p = C_PId.fromInt 0 then NONE else SOME p))
val fork =
if Primitive.MLton.Platform.OS.forkIsEnabled
@@ -34,7 +31,7 @@
else fn () => Error.raiseSys Error.nosys
val conv = NullString.nullTerm
- val convs = COld.CSS.fromList
+ val convs = CUtil.C_StringArray.fromList
fun exece (path, args, env): 'a =
let
@@ -76,7 +73,7 @@
if Prim.ifExited status
then (case Prim.exitStatus status of
0 => W_EXITED
- | n => W_EXITSTATUS (Word8.fromInt n))
+ | n => W_EXITSTATUS (Word8.fromSysWord (C_Int.toSysWord n)))
else if Prim.ifSignaled status
then W_SIGNALED (Prim.termSig status)
else if Prim.ifStopped status
@@ -85,10 +82,11 @@
structure W =
struct
- open W BitFlags
- val continued = SysWord.fromInt CONTINUED
- val nohang = SysWord.fromInt NOHANG
- val untraced = SysWord.fromInt UNTRACED
+ structure Flags = BitFlags(structure S = C_Int)
+ open W Flags
+ (* val continued = CONTINUED *)
+ val nohang = NOHANG
+ val untraced = UNTRACED
end
local
@@ -98,24 +96,23 @@
val useCwait =
Primitive.MLton.Platform.OS.useWindowsProcess
andalso case wa of W_CHILD _ => true | _ => false
- val p =
+ val pid =
case wa of
- W_ANY_CHILD => ~1
- | W_CHILD pid => Pid.toInt pid
- | W_SAME_GROUP => 0
- | W_GROUP pid => ~ (Pid.toInt pid)
+ W_ANY_CHILD => C_PId.fromInt ~1
+ | W_CHILD pid => pid
+ | W_SAME_GROUP => C_PId.fromInt 0
+ | W_GROUP pid => C_PId.~ pid
val flags = W.flags flags
in
- SysCall.syscallRestart
- (fn () =>
+ SysCall.simpleResultRestart'
+ ({errVal = C_PId.fromInt ~1}, fn () =>
let
val pid =
if useCwait
- then PrimitiveFFI.MLton.Process.cwait (Pid.fromInt p, status)
- else Prim.waitpid (Pid.fromInt p, status,
- SysWord.toInt flags)
+ then PrimitiveFFI.MLton.Process.cwait (pid, status)
+ else Prim.waitpid (pid, status, flags)
in
- (Pid.toInt pid, fn () => pid)
+ pid
end)
end
fun getStatus () = fromStatus (!status)
@@ -131,7 +128,7 @@
let
val pid = wait (wa, status, W.nohang :: flags)
in
- if 0 = Pid.toInt pid
+ if C_PId.fromInt 0 = pid
then NONE
else SOME (pid, getStatus ())
end
@@ -143,7 +140,7 @@
(* Posix.Process.exit does not call atExit cleaners, as per the basis
* library spec.
*)
- (Prim.exit (Word8.toInt w)
+ (Prim.exit (C_Status.fromSysWord (Word8.toSysWord w))
; raise Fail "Posix.Process.exit")
datatype killpid_arg =
@@ -155,41 +152,41 @@
let
val pid =
case ka of
- K_PROC pid => Pid.toInt pid
- | K_SAME_GROUP => ~1
- | K_GROUP pid => ~ (Pid.toInt pid)
+ K_PROC pid => pid
+ | K_SAME_GROUP => C_PId.fromInt ~1
+ | K_GROUP pid => C_PId.~ pid
in
- SysCall.simple (fn () => Prim.kill (Pid.fromInt pid, s))
+ SysCall.simple (fn () => Prim.kill (pid, s))
end
local
fun wrap prim (t: Time.time): Time.time =
Time.fromSeconds
- (LargeInt.fromInt
- (C_UInt.toInt
- (prim
- (C_UInt.fromInt
- (LargeInt.toInt (Time.toSeconds t)
- handle Overflow => Error.raiseSys Error.inval)))))
+ (C_UInt.toLargeInt
+ (prim
+ ((C_UInt.fromLargeInt (Time.toSeconds t))
+ handle Overflow => Error.raiseSys Error.inval)))
in
val alarm = wrap Prim.alarm
-(* val sleep = wrap Prim.sleep *)
+ (* val sleep = wrap Prim.sleep *)
end
fun sleep (t: Time.time): Time.time =
let
- val (sec, nsec) = IntInf.quotRem (Time.toNanoseconds t, 1000000000)
+ val t = Time.toNanoseconds t
+ val sec = LargeInt.quot (t, 1000000000)
+ val nsec = LargeInt.rem (t, 1000000000)
val (sec, nsec) =
- (IntInf.toInt sec, IntInf.toInt nsec)
+ (C_Time.fromLarge sec, C_Long.fromLarge nsec)
handle Overflow => Error.raiseSys Error.inval
val secRem = ref sec
val nsecRem = ref nsec
- fun remaining () =
- Time.+ (Time.fromSeconds (Int.toLarge (!secRem)),
- Time.fromNanoseconds (Int.toLarge (!nsecRem)))
+ fun remaining _ =
+ Time.+ (Time.fromSeconds (C_Time.toLarge (!secRem)),
+ Time.fromNanoseconds (C_Long.toLarge (!nsecRem)))
in
SysCall.syscallErr
- ({clear = false, restart = false}, fn () =>
+ ({clear = false, restart = false, errVal = C_Int.fromInt ~1}, fn () =>
{handlers = [(Error.intr, remaining)],
post = remaining,
return = Prim.nanosleep (secRem, nsecRem)})
@@ -198,9 +195,9 @@
(* FIXME: pause *)
fun pause () =
SysCall.syscallErr
- ({clear = false, restart = false},
+ ({clear = false, restart = false, errVal = C_Int.fromInt ~1},
fn () =>
{return = Prim.pause (),
- post = fn () => (),
+ post = fn _ => (),
handlers = [(Error.intr, fn () => ())]})
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/posix/stub-mingw.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/posix/stub-mingw.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/posix/stub-mingw.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -10,14 +10,13 @@
structure Error = PosixError
val stub: string * ('a -> 'b) -> ('a -> 'b) =
fn (msg, f) =>
- if let open Primitive.MLton.Platform.OS
- in MinGW = host
- end
- then fn _ => (if true then ()
- else (Primitive.Stdio.print msg
- ; Primitive.Stdio.print "\n")
+ if let open Primitive.MLton.Platform.OS in MinGW = host end
+ then fn _ => (if true
+ then ()
+ else (PrimitiveFFI.Stdio.print msg
+ ; PrimitiveFFI.Stdio.print "\n")
; Error.raiseSys Error.nosys)
- else f
+ else f
in
structure PrimitiveFFI =
struct
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/posix/sys-db.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/posix/sys-db.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/posix/sys-db.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -8,7 +8,6 @@
structure PosixSysDB: POSIX_SYS_DB =
struct
- structure CS = COld.CS
structure Prim = PrimitiveFFI.Posix.SysDB
structure Error = PosixError
structure SysCall = Error.SysCall
@@ -27,14 +26,14 @@
structure Passwd = Prim.Passwd
fun fromC (f: unit -> bool): passwd =
- SysCall.syscall
- (fn () =>
- (if f () then 0 else ~1,
- fn () => {name = CS.toString(Passwd.getName ()),
- uid = Passwd.getUId (),
- gid = Passwd.getGId (),
- home = CS.toString(Passwd.getDir ()),
- shell = CS.toString(Passwd.getShell ())}))
+ SysCall.syscall'
+ ({errVal = false}, fn () =>
+ (C_Errno.inject (f ()),
+ fn _ => {name = CUtil.C_String.toString (Passwd.getName ()),
+ uid = Passwd.getUId (),
+ gid = Passwd.getGId (),
+ home = CUtil.C_String.toString (Passwd.getDir ()),
+ shell = CUtil.C_String.toString (Passwd.getShell ())}))
val name: passwd -> string = #name
val uid: passwd -> uid = #uid
@@ -59,12 +58,12 @@
structure Group = Prim.Group
fun fromC (f: unit -> bool): group =
- SysCall.syscall
- (fn () =>
- (if f () then 0 else ~1,
- fn () => {name = CS.toString(Group.getName ()),
- gid = Group.getGId (),
- members = COld.CSS.toList(Group.getMem ())}))
+ SysCall.syscall'
+ ({errVal = false}, fn () =>
+ (C_Errno.inject (f ()),
+ fn _ => {name = CUtil.C_String.toString (Group.getName ()),
+ gid = Group.getGId (),
+ members = CUtil.C_StringArray.toList (Group.getMem ())}))
val name: group -> string = #name
val gid: group -> gid = #gid
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/posix/tty.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/posix/tty.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/posix/tty.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -8,7 +8,6 @@
structure PosixTTY: POSIX_TTY =
struct
- structure Cstring = COld.CS
structure Prim = PrimitiveFFI.Posix.TTY
open Prim
structure Error = PosixError
@@ -21,27 +20,29 @@
structure V =
struct
open V
- val nccs = NCCS
- val eof = VEOF
- val eol = VEOL
- val erase = VERASE
- val intr = VINTR
- val kill = VKILL
- val min = VMIN
- val quit = VQUIT
- val susp = VSUSP
- val time = VTIME
- val start = VSTART
- val stop = VSTOP
+ val nccs = C_Int.toInt NCCS
+ val eof = C_Int.toInt VEOF
+ val eol = C_Int.toInt VEOL
+ val erase = C_Int.toInt VERASE
+ val intr = C_Int.toInt VINTR
+ val kill = C_Int.toInt VKILL
+ val min = C_Int.toInt VMIN
+ val quit = C_Int.toInt VQUIT
+ val susp = C_Int.toInt VSUSP
+ val time = C_Int.toInt VTIME
+ val start = C_Int.toInt VSTART
+ val stop = C_Int.toInt VSTOP
type cc = C_CC.t array
- val default = Byte.charToByte #"\000"
+ val default = C_CC.fromSysWord 0w0
- fun new () = Array.array (NCCS, default)
+ fun new () = Array.array (nccs, default)
fun updates (a, l) =
- List.app (fn (i, cc) => Array.update (a, i, Byte.charToByte cc)) l
+ List.app (fn (i, cc) =>
+ Array.update (a, i, (C_CC.fromSysWord o Word8.toSysWord o Byte.charToByte) cc))
+ l
fun cc l = let val a = new ()
in updates (a, l)
@@ -55,12 +56,13 @@
; a'
end
- val sub = Byte.byteToChar o Array.sub
+ val sub = (Byte.byteToChar o Word8.fromSysWord o C_CC.toSysWord) o Array.sub
end
+ structure Flags = BitFlags(structure S = C_TCFlag)
structure I =
struct
- open I BitFlags
+ open I Flags
val brkint = BRKINT
val icrnl = ICRNL
val ignbrk = IGNBRK
@@ -77,7 +79,7 @@
structure O =
struct
- open O BitFlags
+ open O Flags
val bs0 = BS0
val bs1 = BS1
val bsdly = BSDLY
@@ -110,7 +112,7 @@
structure C =
struct
- open C BitFlags
+ open C Flags
val clocal = CLOCAL
val cread = CREAD
val cs5 = CS5
@@ -126,7 +128,7 @@
structure L =
struct
- open L BitFlags
+ open L Flags
val echo = ECHO
val echoe = ECHOE
val echok = ECHOK
@@ -157,10 +159,9 @@
val b75 = B75
val b9600 = B9600
- val compareSpeed = SysWord.compare
- fun id x = x
- val speedToWord = id
- val wordToSpeed = id
+ val compareSpeed = C_Speed.compare
+ val speedToWord = C_Speed.toSysWord
+ val wordToSpeed = C_Speed.fromSysWord
type termios = {iflag: I.flags,
oflag: O.flags,
@@ -170,6 +171,7 @@
ispeed: speed,
ospeed: speed}
+ val id = fn x => x
val termios = id
val fieldsOf = id
@@ -230,7 +232,7 @@
fun getattr fd =
SysCall.syscallRestart
(fn () =>
- (Prim.TC.getattr fd, fn () =>
+ (Prim.TC.getattr fd, fn _ =>
{iflag = Termios.getIFlag (),
oflag = Termios.getOFlag (),
cflag = Termios.getCFlag (),
@@ -252,10 +254,10 @@
; SysCall.simple (fn () => Termios.cfSetOSpeed ospeed)
; SysCall.simple (fn () => Termios.cfSetISpeed ispeed)
; Termios.setCC cc
- ; (Prim.TC.setattr (fd, a), fn () => ())))
+ ; (Prim.TC.setattr (fd, a), fn _ => ())))
fun sendbreak (fd, n) =
- SysCall.simpleRestart (fn () => Prim.TC.sendbreak (fd, n))
+ SysCall.simpleRestart (fn () => Prim.TC.sendbreak (fd, C_Int.fromInt n))
fun drain fd = SysCall.simpleRestart (fn () => Prim.TC.drain fd)
@@ -266,11 +268,9 @@
SysCall.simpleRestart (fn () => Prim.TC.flow (fd, n))
fun getpgrp fd =
- SysCall.syscallRestart
- (fn () =>
- let val pid = Prim.TC.getpgrp fd
- in (Pid.toInt pid, fn () => pid)
- end)
+ SysCall.simpleResultRestart'
+ ({errVal = C_PId.fromInt ~1}, fn () =>
+ Prim.TC.getpgrp fd)
fun setpgrp (fd, pid) =
SysCall.simpleRestart (fn () => Prim.TC.setpgrp (fd, pid))
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/basis-ffi.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/basis-ffi.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/basis-ffi.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -40,6 +40,14 @@
end
structure IEEEReal =
struct
+structure FloatClass =
+struct
+val FP_INFINITE = _const "IEEEReal_FloatClass_FP_INFINITE" : C_Int.t;
+val FP_NAN = _const "IEEEReal_FloatClass_FP_NAN" : C_Int.t;
+val FP_NORMAL = _const "IEEEReal_FloatClass_FP_NORMAL" : C_Int.t;
+val FP_SUBNORMAL = _const "IEEEReal_FloatClass_FP_SUBNORMAL" : C_Int.t;
+val FP_ZERO = _const "IEEEReal_FloatClass_FP_ZERO" : C_Int.t;
+end
val getRoundingMode = _import "IEEEReal_getRoundingMode" : unit -> C_Int.t;
structure RoundingMode =
struct
@@ -53,6 +61,7 @@
end
structure MLton =
struct
+val bug = _import "MLton_bug" : NullString8.t -> unit;
structure Itimer =
struct
val PROF = _const "MLton_Itimer_PROF" : C_Int.t;
@@ -196,6 +205,60 @@
val POLLPRI = _const "OS_IO_POLLPRI" : C_Short.t;
end
end
+structure PackReal32 =
+struct
+val subArr = _import "PackReal32_subArr" : (Word8.t) array * C_Ptrdiff.t -> Real32.t;
+val subArrRev = _import "PackReal32_subArrRev" : (Word8.t) array * C_Ptrdiff.t -> Real32.t;
+val subVec = _import "PackReal32_subVec" : (Word8.t) vector * C_Ptrdiff.t -> Real32.t;
+val subVecRev = _import "PackReal32_subVecRev" : (Word8.t) vector * C_Ptrdiff.t -> Real32.t;
+val update = _import "PackReal32_update" : (Word8.t) array * C_Ptrdiff.t * Real32.t -> unit;
+val updateRev = _import "PackReal32_updateRev" : (Word8.t) array * C_Ptrdiff.t * Real32.t -> unit;
+end
+structure PackReal64 =
+struct
+val subArr = _import "PackReal64_subArr" : (Word8.t) array * C_Ptrdiff.t -> Real64.t;
+val subArrRev = _import "PackReal64_subArrRev" : (Word8.t) array * C_Ptrdiff.t -> Real64.t;
+val subVec = _import "PackReal64_subVec" : (Word8.t) vector * C_Ptrdiff.t -> Real64.t;
+val subVecRev = _import "PackReal64_subVecRev" : (Word8.t) vector * C_Ptrdiff.t -> Real64.t;
+val update = _import "PackReal64_update" : (Word8.t) array * C_Ptrdiff.t * Real64.t -> unit;
+val updateRev = _import "PackReal64_updateRev" : (Word8.t) array * C_Ptrdiff.t * Real64.t -> unit;
+end
+structure PackWord16 =
+struct
+val subArr = _import "PackWord16_subArr" : (Word8.t) array * C_Ptrdiff.t -> Word16.t;
+val subArrRev = _import "PackWord16_subArrRev" : (Word8.t) array * C_Ptrdiff.t -> Word16.t;
+val subVec = _import "PackWord16_subVec" : (Word8.t) vector * C_Ptrdiff.t -> Word16.t;
+val subVecRev = _import "PackWord16_subVecRev" : (Word8.t) vector * C_Ptrdiff.t -> Word16.t;
+val update = _import "PackWord16_update" : (Word8.t) array * C_Ptrdiff.t * Word16.t -> unit;
+val updateRev = _import "PackWord16_updateRev" : (Word8.t) array * C_Ptrdiff.t * Word16.t -> unit;
+end
+structure PackWord32 =
+struct
+val subArr = _import "PackWord32_subArr" : (Word8.t) array * C_Ptrdiff.t -> Word32.t;
+val subArrRev = _import "PackWord32_subArrRev" : (Word8.t) array * C_Ptrdiff.t -> Word32.t;
+val subVec = _import "PackWord32_subVec" : (Word8.t) vector * C_Ptrdiff.t -> Word32.t;
+val subVecRev = _import "PackWord32_subVecRev" : (Word8.t) vector * C_Ptrdiff.t -> Word32.t;
+val update = _import "PackWord32_update" : (Word8.t) array * C_Ptrdiff.t * Word32.t -> unit;
+val updateRev = _import "PackWord32_updateRev" : (Word8.t) array * C_Ptrdiff.t * Word32.t -> unit;
+end
+structure PackWord64 =
+struct
+val subArr = _import "PackWord64_subArr" : (Word8.t) array * C_Ptrdiff.t -> Word64.t;
+val subArrRev = _import "PackWord64_subArrRev" : (Word8.t) array * C_Ptrdiff.t -> Word64.t;
+val subVec = _import "PackWord64_subVec" : (Word8.t) vector * C_Ptrdiff.t -> Word64.t;
+val subVecRev = _import "PackWord64_subVecRev" : (Word8.t) vector * C_Ptrdiff.t -> Word64.t;
+val update = _import "PackWord64_update" : (Word8.t) array * C_Ptrdiff.t * Word64.t -> unit;
+val updateRev = _import "PackWord64_updateRev" : (Word8.t) array * C_Ptrdiff.t * Word64.t -> unit;
+end
+structure PackWord8 =
+struct
+val subArr = _import "PackWord8_subArr" : (Word8.t) array * C_Ptrdiff.t -> Word8.t;
+val subArrRev = _import "PackWord8_subArrRev" : (Word8.t) array * C_Ptrdiff.t -> Word8.t;
+val subVec = _import "PackWord8_subVec" : (Word8.t) vector * C_Ptrdiff.t -> Word8.t;
+val subVecRev = _import "PackWord8_subVecRev" : (Word8.t) vector * C_Ptrdiff.t -> Word8.t;
+val update = _import "PackWord8_update" : (Word8.t) array * C_Ptrdiff.t * Word8.t -> unit;
+val updateRev = _import "PackWord8_updateRev" : (Word8.t) array * C_Ptrdiff.t * Word8.t -> unit;
+end
structure Posix =
struct
structure Error =
@@ -437,7 +500,7 @@
val fcntl3 = _import "Posix_IO_fcntl3" : C_Fd.t * C_Int.t * C_Int.t -> (C_Int.t) C_Errno.t;
structure FD =
struct
-val CLOEXEC = _const "Posix_IO_FD_CLOEXEC" : C_Fd.t;
+val CLOEXEC = _const "Posix_IO_FD_CLOEXEC" : C_Int.t;
end
structure FLock =
struct
@@ -533,7 +596,6 @@
val SC_GETPW_R_SIZE_MAX = _const "Posix_ProcEnv_SC_GETPW_R_SIZE_MAX" : C_Int.t;
val SC_HOST_NAME_MAX = _const "Posix_ProcEnv_SC_HOST_NAME_MAX" : C_Int.t;
val SC_IOV_MAX = _const "Posix_ProcEnv_SC_IOV_MAX" : C_Int.t;
-val SC_IPV6 = _const "Posix_ProcEnv_SC_IPV6" : C_Int.t;
val SC_JOB_CONTROL = _const "Posix_ProcEnv_SC_JOB_CONTROL" : C_Int.t;
val SC_LINE_MAX = _const "Posix_ProcEnv_SC_LINE_MAX" : C_Int.t;
val SC_LOGIN_NAME_MAX = _const "Posix_ProcEnv_SC_LOGIN_NAME_MAX" : C_Int.t;
@@ -551,7 +613,6 @@
val SC_PAGESIZE = _const "Posix_ProcEnv_SC_PAGESIZE" : C_Int.t;
val SC_PRIORITIZED_IO = _const "Posix_ProcEnv_SC_PRIORITIZED_IO" : C_Int.t;
val SC_PRIORITY_SCHEDULING = _const "Posix_ProcEnv_SC_PRIORITY_SCHEDULING" : C_Int.t;
-val SC_RAW_SOCKETS = _const "Posix_ProcEnv_SC_RAW_SOCKETS" : C_Int.t;
val SC_RE_DUP_MAX = _const "Posix_ProcEnv_SC_RE_DUP_MAX" : C_Int.t;
val SC_READER_WRITER_LOCKS = _const "Posix_ProcEnv_SC_READER_WRITER_LOCKS" : C_Int.t;
val SC_REALTIME_SIGNALS = _const "Posix_ProcEnv_SC_REALTIME_SIGNALS" : C_Int.t;
@@ -663,7 +724,6 @@
val termSig = _import "Posix_Process_termSig" : C_Status.t -> C_Signal.t;
structure W =
struct
-val CONTINUED = _const "Posix_Process_W_CONTINUED" : C_Int.t;
val NOHANG = _const "Posix_Process_W_NOHANG" : C_Int.t;
val UNTRACED = _const "Posix_Process_W_UNTRACED" : C_Int.t;
end
@@ -886,6 +946,78 @@
end
end
end
+structure Real32 =
+struct
+val abs = _import "Real32_abs" : Real32.t -> Real32.t;
+val class = _import "Real32_class" : Real32.t -> C_Int.t;
+val frexp = _import "Real32_frexp" : Real32.t * (C_Int.t) ref -> Real32.t;
+val gdtoa = _import "Real32_gdtoa" : Real32.t * C_Int.t * C_Int.t * (C_Int.t) ref -> C_String.t;
+val ldexp = _import "Real32_ldexp" : Real32.t * C_Int.t -> Real32.t;
+structure Math =
+struct
+val acos = _import "Real32_Math_acos" : Real32.t -> Real32.t;
+val asin = _import "Real32_Math_asin" : Real32.t -> Real32.t;
+val atan = _import "Real32_Math_atan" : Real32.t -> Real32.t;
+val atan2 = _import "Real32_Math_atan2" : Real32.t * Real32.t -> Real32.t;
+val cos = _import "Real32_Math_cos" : Real32.t -> Real32.t;
+val cosh = _import "Real32_Math_cosh" : Real32.t -> Real32.t;
+val (eGet, eSet) = _symbol "Real32_Math_e": (unit -> (Real32.t)) * ((Real32.t) -> unit);
+val exp = _import "Real32_Math_exp" : Real32.t -> Real32.t;
+val ln = _import "Real32_Math_ln" : Real32.t -> Real32.t;
+val log10 = _import "Real32_Math_log10" : Real32.t -> Real32.t;
+val (piGet, piSet) = _symbol "Real32_Math_pi": (unit -> (Real32.t)) * ((Real32.t) -> unit);
+val pow = _import "Real32_Math_pow" : Real32.t * Real32.t -> Real32.t;
+val sin = _import "Real32_Math_sin" : Real32.t -> Real32.t;
+val sinh = _import "Real32_Math_sinh" : Real32.t -> Real32.t;
+val sqrt = _import "Real32_Math_sqrt" : Real32.t -> Real32.t;
+val tan = _import "Real32_Math_tan" : Real32.t -> Real32.t;
+val tanh = _import "Real32_Math_tanh" : Real32.t -> Real32.t;
+end
+val (maxFiniteGet, maxFiniteSet) = _symbol "Real32_maxFinite": (unit -> (Real32.t)) * ((Real32.t) -> unit);
+val (minNormalPosGet, minNormalPosSet) = _symbol "Real32_minNormalPos": (unit -> (Real32.t)) * ((Real32.t) -> unit);
+val (minPosGet, minPosSet) = _symbol "Real32_minPos": (unit -> (Real32.t)) * ((Real32.t) -> unit);
+val modf = _import "Real32_modf" : Real32.t * (Real32.t) ref -> Real32.t;
+val nextAfter = _import "Real32_nextAfter" : Real32.t * Real32.t -> Real32.t;
+val round = _import "Real32_round" : Real32.t -> Real32.t;
+val signBit = _import "Real32_signBit" : Real32.t -> C_Int.t;
+val strto = _import "Real32_strto" : NullString8.t -> Real32.t;
+end
+structure Real64 =
+struct
+val abs = _import "Real64_abs" : Real64.t -> Real64.t;
+val class = _import "Real64_class" : Real64.t -> C_Int.t;
+val frexp = _import "Real64_frexp" : Real64.t * (C_Int.t) ref -> Real64.t;
+val gdtoa = _import "Real64_gdtoa" : Real64.t * C_Int.t * C_Int.t * (C_Int.t) ref -> C_String.t;
+val ldexp = _import "Real64_ldexp" : Real64.t * C_Int.t -> Real64.t;
+structure Math =
+struct
+val acos = _import "Real64_Math_acos" : Real64.t -> Real64.t;
+val asin = _import "Real64_Math_asin" : Real64.t -> Real64.t;
+val atan = _import "Real64_Math_atan" : Real64.t -> Real64.t;
+val atan2 = _import "Real64_Math_atan2" : Real64.t * Real64.t -> Real64.t;
+val cos = _import "Real64_Math_cos" : Real64.t -> Real64.t;
+val cosh = _import "Real64_Math_cosh" : Real64.t -> Real64.t;
+val (eGet, eSet) = _symbol "Real64_Math_e": (unit -> (Real64.t)) * ((Real64.t) -> unit);
+val exp = _import "Real64_Math_exp" : Real64.t -> Real64.t;
+val ln = _import "Real64_Math_ln" : Real64.t -> Real64.t;
+val log10 = _import "Real64_Math_log10" : Real64.t -> Real64.t;
+val (piGet, piSet) = _symbol "Real64_Math_pi": (unit -> (Real64.t)) * ((Real64.t) -> unit);
+val pow = _import "Real64_Math_pow" : Real64.t * Real64.t -> Real64.t;
+val sin = _import "Real64_Math_sin" : Real64.t -> Real64.t;
+val sinh = _import "Real64_Math_sinh" : Real64.t -> Real64.t;
+val sqrt = _import "Real64_Math_sqrt" : Real64.t -> Real64.t;
+val tan = _import "Real64_Math_tan" : Real64.t -> Real64.t;
+val tanh = _import "Real64_Math_tanh" : Real64.t -> Real64.t;
+end
+val (maxFiniteGet, maxFiniteSet) = _symbol "Real64_maxFinite": (unit -> (Real64.t)) * ((Real64.t) -> unit);
+val (minNormalPosGet, minNormalPosSet) = _symbol "Real64_minNormalPos": (unit -> (Real64.t)) * ((Real64.t) -> unit);
+val (minPosGet, minPosSet) = _symbol "Real64_minPos": (unit -> (Real64.t)) * ((Real64.t) -> unit);
+val modf = _import "Real64_modf" : Real64.t * (Real64.t) ref -> Real64.t;
+val nextAfter = _import "Real64_nextAfter" : Real64.t * Real64.t -> Real64.t;
+val round = _import "Real64_round" : Real64.t -> Real64.t;
+val signBit = _import "Real64_signBit" : Real64.t -> C_Int.t;
+val strto = _import "Real64_strto" : NullString8.t -> Real64.t;
+end
structure Socket =
struct
val accept = _import "Socket_accept" : C_Sock.t * (Word8.t) array * (C_Socklen.t) ref -> (C_Int.t) C_Errno.t;
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/check-pack-real.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/check-pack-real.sml)
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/check-pack-word.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/check-pack-word.sml)
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/check-real.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/check-real.sml)
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-basis.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-basis.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-basis.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -6,6 +6,8 @@
* See the file MLton-LICENSE for details.
*)
+structure Primitive = struct
+
(* Primitive Basis (Definition) *)
structure Bool =
struct
@@ -443,12 +445,13 @@
type 'a t = 'a weak
end
+end
(* Top-level bindings *)
-datatype bool = datatype Bool.bool
-type exn = Exn.exn
-datatype list = datatype List.list
-datatype ref = datatype Ref.ref
-type unit = Unit.unit
-type 'a array = 'a Array.array
-type 'a vector = 'a Vector.vector
+datatype bool = datatype Primitive.Bool.bool
+type exn = Primitive.Exn.exn
+datatype list = datatype Primitive.List.list
+datatype ref = datatype Primitive.Ref.ref
+type unit = Primitive.Unit.unit
+type 'a array = 'a Primitive.Array.array
+type 'a vector = 'a Primitive.Vector.vector
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-char.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-char.sml)
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-int-inf.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-int-inf.sml)
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-int.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-int.sml)
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-mlton.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-mlton.sml)
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-nullstring.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-nullstring.sml)
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-pack-real.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-pack-real.sml)
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-pack-word.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-pack-word.sml)
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-real.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-real.sml)
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-seq.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-seq.sml)
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-string.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-string.sml)
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-word.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-word.sml)
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim1.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim1.sml)
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim2.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim2.sml)
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/primitive.mlb
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/primitive.mlb 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/primitive.mlb 2006-05-06 18:44:35 UTC (rev 4468)
@@ -9,7 +9,6 @@
"allowConstant true"
"allowFFI true"
"allowPrim true"
- "allowRebindEquals true"
"deadCode true"
"nonexhaustiveMatch warn"
"redundantMatch warn"
@@ -17,12 +16,60 @@
"warnUnused false"
in
prim-basis.mlb
- ann "forceUsed" in
+ ann "allowRebindEquals true" in
+ prim1.sml
+ end
+ ../util/integral-comparisons.sml
+ ../util/string-comparisons.sml
+ ../util/real-comparisons.sml
+ local
+ ../config/bind/char-prim.sml
+ ../config/bind/int-prim.sml
+ ../config/bind/int-inf-prim.sml
+ ../config/bind/real-prim.sml
+ ../config/bind/string-prim.sml
+ ../config/bind/word-prim.sml
+ in ann "forceUsed" in
../config/choose.sml
+ end end
+
+ prim-word.sml
+ prim-int.sml
+
+ local
+ ../config/bind/int-prim.sml
+ ../config/bind/pointer-prim.sml
+ ../config/bind/real-prim.sml
+ ../config/bind/word-prim.sml
+ in ann "forceUsed" in
+ ../config/objptr/$(OBJPTR_REP)
+ ../config/header/$(HEADER_WORD)
+ ../config/seqindex/$(SEQINDEX_INT)
../config/c/$(TARGET_ARCH)-$(TARGET_OS)/c-types.sml
- end
- primitive.sml
- ann "forceUsed" in
- basis-ffi.sml
- end
+ ../config/c/errno.sml
+ ../config/c/position.sml
+ ../config/c/sys-word.sml
+ end end
+ prim-seq.sml
+ prim-nullstring.sml
+
+ prim-int-inf.sml
+
+ prim-char.sml
+ prim-string.sml
+
+ prim-real.sml
+
+ prim-pack-word.sml
+ prim-pack-real.sml
+
+ prim-mlton.sml
+
+ basis-ffi.sml
+ prim2.sml
+
+ (* Check compatibility between primitives and runtime functions. *)
+ check-real.sml
+ check-pack-word.sml
+ check-pack-real.sml
end
Deleted: mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/primitive.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/primitive.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/primitive.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -1,1697 +0,0 @@
-(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
- * Jagannathan, and Stephen Weeks.
- * Copyright (C) 1997-2000 NEC Research Institute.
- *
- * MLton is released under a BSD-style license.
- * See the file MLton-LICENSE for details.
- *)
-
-(* Primitive names are special -- see atoms/prim.fun. *)
-
-infix 4 = (* <> > >= < <= *)
-
-val op = = fn z => _prim "MLton_equal": ''a * ''a -> bool; z
-
-structure Char = Char8
-type char = Char.char
-structure Int = Int32
-type int = Int.int
-structure Real = Real64
-type real = Real.real
-
-structure String = String8
-type string = String.string
-
-structure PreThread :> sig type t end = struct type t = Thread.t end
-structure Thread :> sig type t end = struct type t = Thread.t end
-
-structure Word = Word32
-type word = Word.word
-structure LargeWord = Word64
-
-(* NullString is used for strings that must be passed to C and hence must be
- * null terminated. After the Primitive structure is defined,
- * NullString.fromString is replaced by a version that checks that the string
- * is indeed null terminated. See the bottom of this file.
- *)
-structure NullString :>
- sig
- type t
-
- val fromString: string -> t
- end =
- struct
- type t = string
-
- val fromString = fn s => s
- end
-
-structure GetSet =
- struct
- type 'a t = (unit -> 'a) * ('a -> unit)
- end
-
-structure Pid : sig
- eqtype t
-
- val fromInt: int -> t
- val toInt: t -> int
- end =
- struct
- type t = int
-
- val fromInt = fn i => i
- val toInt = fn i => i
- val _ = fromInt
- end
-
-exception Bind = Exn.Bind
-exception Fail of string
-exception Match = Exn.Match
-exception PrimOverflow = Exn.PrimOverflow
-exception Overflow
-exception Size
-
-val wrapOverflow: ('a -> 'b) -> ('a -> 'b) =
- fn f => fn a => f a handle PrimOverflow => raise Overflow
-
-datatype 'a option = NONE | SOME of 'a
-
-fun not b = if b then false else true
-
-functor Comparisons (type t
- val < : t * t -> bool) =
- struct
- fun <= (a, b) = not (< (b, a))
- fun > (a, b) = < (b, a)
- fun >= (a, b) = <= (b, a)
- end
-
-functor RealComparisons (type t
- val < : t * t -> bool
- val <= : t * t -> bool) =
- struct
- fun > (a, b) = < (b, a)
- fun >= (a, b) = <= (b, a)
- end
-
-structure Primitive =
- struct
- val bug = _import "MLton_bug": NullString.t -> unit;
- val debug = _command_line_const "MLton.debug": bool = false;
- val detectOverflow =
- _command_line_const "MLton.detectOverflow": bool = true;
- val eq = _prim "MLton_eq": 'a * 'a -> bool;
- val installSignalHandler =
- _prim "MLton_installSignalHandler": unit -> unit;
- val safe = _command_line_const "MLton.safe": bool = true;
- val touch = _prim "MLton_touch": 'a -> unit;
- val usesCallcc: bool ref = ref false;
-
- structure Stdio =
- struct
- val print = _import "Stdio_print": string -> unit;
- end
-
- structure Array =
- struct
- val array0Const = _prim "Array_array0Const": unit -> 'a array;
- val length = _prim "Array_length": 'a array -> int;
- (* There is no maximum length on arrays, so maxLen = maxInt. *)
- val maxLen: int = 0x7FFFFFFF
- val sub = _prim "Array_sub": 'a array * int -> 'a;
- val update = _prim "Array_update": 'a array * int * 'a -> unit;
- end
-
- structure CString =
- struct
- type t = Pointer.t
- end
-
- structure GCState =
- struct
- type t = Pointer.t
-
- val gcState = #1 _symbol "gcStateAddress": t GetSet.t; ()
- end
-
- structure CallStack =
- struct
- (* The most recent caller is at index 0 in the array. *)
- datatype t = T of int array
-
- val callStack =
- _import "GC_callStack": GCState.t * int array -> unit;
- val frameIndexSourceSeq =
- _import "GC_frameIndexSourceSeq": GCState.t * int -> Pointer.t;
- val keep = _command_line_const "CallStack.keep": bool = false;
- val numStackFrames =
- _import "GC_numStackFrames": GCState.t -> int;
- val sourceName = _import "GC_sourceName": GCState.t * int -> CString.t;
- end
-
- structure Char =
- struct
- open Char
-
- val op < = _prim "WordU8_lt": char * char -> bool;
- val chr = _prim "WordS32_toWord8": int -> char;
- val ord = _prim "WordU8_toWord32": char -> int;
- val toInt8 = _prim "WordS8_toWord8": char -> Int8.int;
- val fromInt8 = _prim "WordS8_toWord8": Int8.int -> char;
- val toWord8 = _prim "WordU8_toWord8": char -> Word8.word;
- val fromWord8 = _prim "WordU8_toWord8": Word8.word -> char;
- end
-
- structure Char =
- struct
- open Char
- local
- structure S = Comparisons (Char)
- in
- open S
- end
- end
-
- structure Char2 =
- struct
- open Char16
-
- val op < = _prim "WordU16_lt": char * char -> bool;
- val chr = _prim "WordS32_toWord16": int -> char;
- val ord = _prim "WordU16_toWord32": char -> int;
- val toInt16 = _prim "WordS16_toWord16": char -> Int16.int;
- val fromInt16 = _prim "WordS16_toWord16": Int16.int -> char;
- (* val toWord16 = _prim "WordU16_toWord16": char -> Word16.word; *)
- (* val fromWord16 = _prim "WordU16_toWord16": Word16.word -> char; *)
- end
-
- structure Char4 =
- struct
- open Char32
-
- val op < = _prim "WordU32_lt": char * char -> bool;
- val chr = _prim "WordS32_toWord32": int -> char;
- val ord = _prim "WordU32_toWord32": char -> int;
- val toInt32 = _prim "WordS32_toWord32": char -> Int32.int;
- val fromInt32 = _prim "WordS32_toWord32": Int32.int -> char;
- (* val toWord32 = _prim "WordU32_toWord32": char -> Word32.word; *)
- (* val fromWord32 = _prim "WordU32_toWord32": Word32.word -> char; *)
- end
-
- structure Exn =
- struct
- (* The polymorphism with extra and setInitExtra is because primitives
- * are only supposed to deal with basic types. The polymorphism
- * allows the various passes like monomorphisation to translate
- * the types appropriately.
- *)
- type extra = CallStack.t option
-
- val extra = _prim "Exn_extra": exn -> 'a;
- val extra: exn -> extra = extra
- val name = _prim "Exn_name": exn -> string;
- val keepHistory =
- _command_line_const "Exn.keepHistory": bool = false;
- val setExtendExtra = _prim "Exn_setExtendExtra": ('a -> 'a) -> unit;
- val setExtendExtra: (extra -> extra) -> unit = setExtendExtra
- val setInitExtra = _prim "Exn_setInitExtra": 'a -> unit;
- val setInitExtra: extra -> unit = setInitExtra
- end
-
- structure FFI =
- struct
- val getOp = #1 _symbol "MLton_FFI_op": int GetSet.t;
- val int8Array = #1 _symbol "MLton_FFI_Int8": Pointer.t GetSet.t; ()
- val int16Array = #1 _symbol "MLton_FFI_Int16": Pointer.t GetSet.t; ()
- val int32Array = #1 _symbol "MLton_FFI_Int32": Pointer.t GetSet.t; ()
- val int64Array = #1 _symbol "MLton_FFI_Int64": Pointer.t GetSet.t; ()
- val numExports = _build_const "MLton_FFI_numExports": int;
- val pointerArray = #1 _symbol "MLton_FFI_Pointer": Pointer.t GetSet.t; ()
- val real32Array = #1 _symbol "MLton_FFI_Real32": Pointer.t GetSet.t; ()
- val real64Array = #1 _symbol "MLton_FFI_Real64": Pointer.t GetSet.t; ()
- val word8Array = #1 _symbol "MLton_FFI_Word8": Pointer.t GetSet.t; ()
- val word16Array = #1 _symbol "MLton_FFI_Word16": Pointer.t GetSet.t; ()
- val word32Array = #1 _symbol "MLton_FFI_Word32": Pointer.t GetSet.t; ()
- val word64Array = #1 _symbol "MLton_FFI_Word64": Pointer.t GetSet.t; ()
- end
-
- structure GC =
- struct
- val collect = _prim "GC_collect": unit -> unit;
- val pack = _import "GC_pack": GCState.t -> unit;
- val setHashConsDuringGC =
- _import "GC_setHashConsDuringGC": GCState.t * bool -> unit;
- val setMessages =
- _import "GC_setMessages": GCState.t * bool -> unit;
- val setRusageMeasureGC =
- _import "GC_setRusageMeasureGC": GCState.t * bool -> unit;
- val setSummary =
- _import "GC_setSummary": GCState.t * bool -> unit;
- val unpack =
- _import "GC_unpack": GCState.t -> unit;
- end
-
- structure Int1 =
- struct
- open Int1
- type big = Int8.int
- val fromBigUnsafe = _prim "WordU8_toWord1": big -> int;
- val precision' = 1
- val toBig = _prim "WordU1_toWord8": int -> big;
- end
- structure Int2 =
- struct
- open Int2
- type big = Int8.int
- val fromBigUnsafe = _prim "WordU8_toWord2": big -> int;
- val precision' = 2
- val toBig = _prim "WordU2_toWord8": int -> big;
- end
- structure Int3 =
- struct
- open Int3
- type big = Int8.int
- val fromBigUnsafe = _prim "WordU8_toWord3": big -> int;
- val precision' = 3
- val toBig = _prim "WordU3_toWord8": int -> big;
- end
- structure Int4 =
- struct
- open Int4
- type big = Int8.int
- val fromBigUnsafe = _prim "WordU8_toWord4": big -> int;
- val precision' = 4
- val toBig = _prim "WordU4_toWord8": int -> big;
- end
- structure Int5 =
- struct
- open Int5
- type big = Int8.int
- val fromBigUnsafe = _prim "WordU8_toWord5": big -> int;
- val precision' = 5
- val toBig = _prim "WordU5_toWord8": int -> big;
- end
- structure Int6 =
- struct
- open Int6
- type big = Int8.int
- val fromBigUnsafe = _prim "WordU8_toWord6": big -> int;
- val precision' = 6
- val toBig = _prim "WordU6_toWord8": int -> big;
- end
- structure Int7 =
- struct
- open Int7
- type big = Int8.int
- val fromBigUnsafe = _prim "WordU8_toWord7": big -> int;
- val precision' = 7
- val toBig = _prim "WordU7_toWord8": int -> big;
- end
- structure Int8 =
- struct
- type t = Int8.int
- type int = t
-
- val precision' : Int.int = 8
- val maxInt' : int = 0x7f
- val minInt' : int = ~0x80
-
- val *? = _prim "WordS8_mul": int * int -> int;
- val * =
- if detectOverflow
- then wrapOverflow (_prim "WordS8_mulCheck": int * int -> int;)
- else *?
- val +? = _prim "Word8_add": int * int -> int;
- val + =
- if detectOverflow
- then wrapOverflow (_prim "WordS8_addCheck": int * int -> int;)
- else +?
- val -? = _prim "Word8_sub": int * int -> int;
- val - =
- if detectOverflow
- then wrapOverflow (_prim "WordS8_subCheck": int * int -> int;)
- else -?
- val op < = _prim "WordS8_lt": int * int -> bool;
- val quot = _prim "WordS8_quot": int * int -> int;
- val rem = _prim "WordS8_rem": int * int -> int;
- val << = _prim "Word8_lshift": int * Word.word -> int;
- val >> = _prim "WordU8_rshift": int * Word.word -> int;
- val ~>> = _prim "WordS8_rshift": int * Word.word -> int;
- val ~? = _prim "Word8_neg": int -> int;
- val ~ =
- if detectOverflow
- then wrapOverflow (_prim "Word8_negCheck": int -> int;)
- else ~?
- val andb = _prim "Word8_andb": int * int -> int;
- val fromInt = _prim "WordS32_toWord8": Int.int -> int;
- val toInt = _prim "WordS8_toWord32": int -> Int.int;
- end
- structure Int8 =
- struct
- open Int8
- local
- structure S = Comparisons (Int8)
- in
- open S
- end
- end
- structure Int9 =
- struct
- open Int9
- type big = Int16.int
- val fromBigUnsafe = _prim "WordU16_toWord9": big -> int;
- val precision' = 9
- val toBig = _prim "WordU9_toWord16": int -> big;
- end
- structure Int10 =
- struct
- open Int10
- type big = Int16.int
- val fromBigUnsafe = _prim "WordU16_toWord10": big -> int;
- val precision' = 10
- val toBig = _prim "WordU10_toWord16": int -> big;
- end
- structure Int11 =
- struct
- open Int11
- type big = Int16.int
- val fromBigUnsafe = _prim "WordU16_toWord11": big -> int;
- val precision' = 11
- val toBig = _prim "WordU11_toWord16": int -> big;
- end
- structure Int12 =
- struct
- open Int12
- type big = Int16.int
- val fromBigUnsafe = _prim "WordU16_toWord12": big -> int;
- val precision' = 12
- val toBig = _prim "WordU12_toWord16": int -> big;
- end
- structure Int13 =
- struct
- open Int13
- type big = Int16.int
- val fromBigUnsafe = _prim "WordU16_toWord13": big -> int;
- val precision' = 13
- val toBig = _prim "WordU13_toWord16": int -> big;
- end
- structure Int14 =
- struct
- open Int14
- type big = Int16.int
- val fromBigUnsafe = _prim "WordU16_toWord14": big -> int;
- val precision' = 14
- val toBig = _prim "WordU14_toWord16": int -> big;
- end
- structure Int15 =
- struct
- open Int15
- type big = Int16.int
- val fromBigUnsafe = _prim "WordU16_toWord15": big -> int;
- val precision' = 15
- val toBig = _prim "WordU15_toWord16": int -> big;
- end
- structure Int16 =
- struct
- type t = Int16.int
- type int = t
-
- val precision' : Int.int = 16
- val maxInt' : int = 0x7fff
- val minInt' : int = ~0x8000
-
- val *? = _prim "WordS16_mul": int * int -> int;
- val * =
- if detectOverflow
- then (wrapOverflow
- (_prim "WordS16_mulCheck": int * int -> int;))
- else *?
- val +? = _prim "Word16_add": int * int -> int;
- val + =
- if detectOverflow
- then (wrapOverflow
- (_prim "WordS16_addCheck": int * int -> int;))
- else +?
- val -? = _prim "Word16_sub": int * int -> int;
- val - =
- if detectOverflow
- then (wrapOverflow
- (_prim "WordS16_subCheck": int * int -> int;))
- else -?
- val op < = _prim "WordS16_lt": int * int -> bool;
- val quot = _prim "WordS16_quot": int * int -> int;
- val rem = _prim "WordS16_rem": int * int -> int;
- val << = _prim "Word16_lshift": int * Word.word -> int;
- val >> = _prim "WordU16_rshift": int * Word.word -> int;
- val ~>> = _prim "WordS16_rshift": int * Word.word -> int;
- val ~? = _prim "Word16_neg": int -> int;
- val ~ =
- if detectOverflow
- then wrapOverflow (_prim "Word16_negCheck": int -> int;)
- else ~?
- val andb = _prim "Word16_andb": int * int -> int;
- val fromInt = _prim "WordS32_toWord16": Int.int -> int;
- val toInt = _prim "WordS16_toWord32": int -> Int.int;
- end
- structure Int16 =
- struct
- open Int16
- local
- structure S = Comparisons (Int16)
- in
- open S
- end
- end
- structure Int17 =
- struct
- open Int17
- type big = Int32.int
- val fromBigUnsafe = _prim "WordU32_toWord17": big -> int;
- val precision' = 17
- val toBig = _prim "WordU17_toWord32": int -> big;
- end
- structure Int18 =
- struct
- open Int18
- type big = Int32.int
- val fromBigUnsafe = _prim "WordU32_toWord18": big -> int;
- val precision' = 18
- val toBig = _prim "WordU18_toWord32": int -> big;
- end
- structure Int19 =
- struct
- open Int19
- type big = Int32.int
- val fromBigUnsafe = _prim "WordU32_toWord19": big -> int;
- val precision' = 19
- val toBig = _prim "WordU19_toWord32": int -> big;
- end
- structure Int20 =
- struct
- open Int20
- type big = Int32.int
- val fromBigUnsafe = _prim "WordU32_toWord20": big -> int;
- val precision' = 20
- val toBig = _prim "WordU20_toWord32": int -> big;
- end
- structure Int21 =
- struct
- open Int21
- type big = Int32.int
- val fromBigUnsafe = _prim "WordU32_toWord21": big -> int;
- val precision' = 21
- val toBig = _prim "WordU21_toWord32": int -> big;
- end
- structure Int22 =
- struct
- open Int22
- type big = Int32.int
- val fromBigUnsafe = _prim "WordU32_toWord22": big -> int;
- val precision' = 22
- val toBig = _prim "WordU22_toWord32": int -> big;
- end
- structure Int23 =
- struct
- open Int23
- type big = Int32.int
- val fromBigUnsafe = _prim "WordU32_toWord23": big -> int;
- val precision' = 23
- val toBig = _prim "WordU23_toWord32": int -> big;
- end
- structure Int24 =
- struct
- open Int24
- type big = Int32.int
- val fromBigUnsafe = _prim "WordU32_toWord24": big -> int;
- val precision' = 24
- val toBig = _prim "WordU24_toWord32": int -> big;
- end
- structure Int25 =
- struct
- open Int25
- type big = Int32.int
- val fromBigUnsafe = _prim "WordU32_toWord25": big -> int;
- val precision' = 25
- val toBig = _prim "WordU25_toWord32": int -> big;
- end
- structure Int26 =
- struct
- open Int26
- type big = Int32.int
- val fromBigUnsafe = _prim "WordU32_toWord26": big -> int;
- val precision' = 26
- val toBig = _prim "WordU26_toWord32": int -> big;
- end
- structure Int27 =
- struct
- open Int27
- type big = Int32.int
- val fromBigUnsafe = _prim "WordU32_toWord27": big -> int;
- val precision' = 27
- val toBig = _prim "WordU27_toWord32": int -> big;
- end
- structure Int28 =
- struct
- open Int28
- type big = Int32.int
- val fromBigUnsafe = _prim "WordU32_toWord28": big -> int;
- val precision' = 28
- val toBig = _prim "WordU28_toWord32": int -> big;
- end
- structure Int29 =
- struct
- open Int29
- type big = Int32.int
- val fromBigUnsafe = _prim "WordU32_toWord29": big -> int;
- val precision' = 29
- val toBig = _prim "WordU29_toWord32": int -> big;
- end
- structure Int30 =
- struct
- open Int30
- type big = Int32.int
- val fromBigUnsafe = _prim "WordU32_toWord30": big -> int;
- val precision' = 30
- val toBig = _prim "WordU30_toWord32": int -> big;
- end
- structure Int31 =
- struct
- open Int31
- type big = Int32.int
- val fromBigUnsafe = _prim "WordU32_toWord31": big -> int;
- val precision' = 31
- val toBig = _prim "WordU31_toWord32": int -> big;
- end
- structure Int32 =
- struct
- type t = Int32.int
- type int = t
-
- val precision' : Int.int = 32
- val maxInt' : int = 0x7fffffff
- val minInt' : int = ~0x80000000
-
- val *? = _prim "WordS32_mul": int * int -> int;
- val * =
- if detectOverflow
- then (wrapOverflow
- (_prim "WordS32_mulCheck": int * int -> int;))
- else *?
- val +? = _prim "Word32_add": int * int -> int;
- val + =
- if detectOverflow
- then (wrapOverflow
- (_prim "WordS32_addCheck": int * int -> int;))
- else +?
- val -? = _prim "Word32_sub": int * int -> int;
- val - =
- if detectOverflow
- then (wrapOverflow
- (_prim "WordS32_subCheck": int * int -> int;))
- else -?
- val op < = _prim "WordS32_lt": int * int -> bool;
- val quot = _prim "WordS32_quot": int * int -> int;
- val rem = _prim "WordS32_rem": int * int -> int;
- val << = _prim "Word32_lshift": int * Word.word -> int;
- val >> = _prim "WordU32_rshift": int * Word.word -> int;
- val ~>> = _prim "WordS32_rshift": int * Word.word -> int;
- val ~? = _prim "Word32_neg": int -> int;
- val ~ =
- if detectOverflow
- then wrapOverflow (_prim "Word32_negCheck": int -> int;)
- else ~?
- val andb = _prim "Word32_andb": int * int -> int;
- val fromInt : int -> int = fn x => x
- val toInt : int -> int = fn x => x
- end
- structure Int32 =
- struct
- open Int32
- local
- structure S = Comparisons (Int32)
- in
- open S
- end
- end
- structure Int = Int32
- structure Int64 =
- struct
- type t = Int64.int
- type int = t
-
- val precision' : Int.int = 64
- val maxInt' : int = 0x7FFFFFFFFFFFFFFF
- val minInt' : int = ~0x8000000000000000
-
- val *? = _prim "WordS64_mul": int * int -> int;
- val * = fn _ => raise Fail "Int64.* unimplemented"
-(*
- val * =
- if detectOverflow
- then _prim "WordS64_mulCheck": int * int -> int;
- else *?
-*)
- val +? = _prim "Word64_add": int * int -> int;
- val + =
- if detectOverflow
- then (wrapOverflow
- (_prim "WordS64_addCheck": int * int -> int;))
- else +?
- val -? = _prim "Word64_sub": int * int -> int;
- val - =
- if detectOverflow
- then (wrapOverflow
- (_prim "WordS64_subCheck": int * int -> int;))
- else -?
- val op < = _prim "WordS64_lt": int * int -> bool;
- val << = _prim "Word64_lshift": int * Word.word -> int;
- val >> = _prim "WordU64_rshift": int * Word.word -> int;
- val ~>> = _prim "WordS64_rshift": int * Word.word -> int;
- val quot = _prim "WordS64_quot": int * int -> int;
- val rem = _prim "WordS64_rem": int * int -> int;
- val ~? = _prim "Word64_neg": int -> int;
- val ~ =
- if detectOverflow
- then wrapOverflow (_prim "Word64_negCheck": int -> int;)
- else ~?
- val andb = _prim "Word64_andb": int * int -> int;
- val fromInt = _prim "WordS32_toWord64": Int.int -> int;
- val fromWord = _prim "WordU32_toWord64": word -> int;
- val toInt = _prim "WordU64_toWord32": int -> Int.int;
- val toWord = _prim "WordU64_toWord32": int -> word;
- end
- structure Int64 =
- struct
- open Int64
- local
- structure S = Comparisons (Int64)
- in
- open S
- end
- end
-
- structure Array =
- struct
- open Array
-
- val array = _prim "Array_array": int -> 'a array;
- val array =
- fn n => if safe andalso Int.< (n, 0)
- then raise Size
- else array n
- end
-
- structure IntInf =
- struct
- open 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 "WordVector_toIntInf": word vector -> int;
- val fromWord = _prim "Word_toIntInf": 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 - = _prim "IntInf_sub": int * int * word -> int;
- val toString
- = _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 MLton =
- struct
- structure Codegen =
- struct
- datatype t = Bytecode | C | Native
-
- val codegen =
- case _build_const "MLton_Codegen_codegen": int; of
- 0 => Bytecode
- | 1 => C
- | 2 => Native
- | _ => raise Fail "MLton_Codegen_codegen"
-
- val isBytecode = codegen = Bytecode
- (* val isC = codegen = C *)
- val isNative = codegen = Native
- end
-
- (* val deserialize = _prim "MLton_deserialize": Word8Vector.vector -> 'a ref; *)
- (* val serialize = _prim "MLton_serialize": 'a ref -> Word8Vector.vector; *)
- val share = _prim "MLton_share": 'a -> unit;
- val size = _prim "MLton_size": 'a ref -> int;
-
- structure Platform =
- struct
- structure Arch =
- struct
- datatype t = Alpha | AMD64 | ARM | HPPA | IA64 | m68k |
- MIPS | PowerPC | S390 | Sparc | X86
-
- val host: t =
- case _const "MLton_Platform_Arch_host": string; of
- "alpha" => Alpha
- | "amd64" => AMD64
- | "arm" => ARM
- | "hppa" => HPPA
- | "ia64" => IA64
- | "m68k" => m68k
- | "mips" => MIPS
- | "powerpc" => PowerPC
- | "s390" => S390
- | "sparc" => Sparc
- | "x86" => X86
- | _ => raise Fail "strange MLton_Platform_Arch_host"
-
- val hostIsBigEndian =
- _const "MLton_Platform_Arch_bigendian": bool;
- end
-
- structure OS =
- struct
- datatype t =
- Cygwin
- | Darwin
- | FreeBSD
- | HPUX
- | Linux
- | MinGW
- | NetBSD
- | OpenBSD
- | Solaris
-
- val host: t =
- case _const "MLton_Platform_OS_host": string; of
- "cygwin" => Cygwin
- | "darwin" => Darwin
- | "freebsd" => FreeBSD
- | "hpux" => HPUX
- | "linux" => Linux
- | "mingw" => MinGW
- | "netbsd" => NetBSD
- | "openbsd" => OpenBSD
- | "solaris" => Solaris
- | _ => raise Fail "strange MLton_Platform_OS_host"
-
- val forkIsEnabled =
- case host of
- Cygwin =>
- #1 _symbol "MLton_Platform_CygwinUseMmap": bool GetSet.t; ()
- | MinGW => false
- | _ => true
-
- val useWindowsProcess = not forkIsEnabled
- end
- end
-
- structure Profile =
- struct
- val isOn = _build_const "MLton_Profile_isOn": bool;
- structure Data =
- struct
- type t = word
-
- val dummy:t = 0w0
- val free =
- _import "GC_profileFree": GCState.t * t -> unit;
- val malloc =
- _import "GC_profileMalloc": GCState.t -> t;
- val write =
- _import "GC_profileWrite"
- : GCState.t * t * word (* fd *) -> unit;
- end
- val done = _import "GC_profileDone": GCState.t -> unit;
- val getCurrent =
- _import "GC_getProfileCurrent": GCState.t -> Data.t;
- val setCurrent =
- _import "GC_setProfileCurrent"
- : GCState.t * Data.t -> unit;
- end
-
- structure Weak =
- struct
- open Weak
-
- val canGet = _prim "Weak_canGet": 'a t -> bool;
- val get = _prim "Weak_get": 'a t -> 'a;
- val new = _prim "Weak_new": 'a -> 'a t;
- end
- end
-
- structure PackReal32 =
- struct
- type real = Real32.real
-
- val subVec = _import "PackReal32_subVec": Word8.word vector * int -> real;
- val subVecRev =
- _import "PackReal32_subVecRev": Word8.word vector * int -> real;
- val update =
- _import "PackReal32_update": Word8.word array * int * real -> unit;
- val updateRev =
- _import "PackReal32_updateRev": Word8.word array * int * real -> unit;
- end
-
- structure PackReal64 =
- struct
- type real = Real64.real
-
- val subVec = _import "PackReal64_subVec": Word8.word vector * int -> real;
- val subVecRev =
- _import "PackReal64_subVecRev": Word8.word vector * int -> real;
- val update =
- _import "PackReal64_update": Word8.word array * int * real -> unit;
- val updateRev =
- _import "PackReal64_updateRev": Word8.word array * int * real -> unit;
- end
-
- structure Pointer =
- struct
- open Pointer
-
- val fromWord = _prim "WordU32_toWord32": word -> t;
- val toWord = _prim "WordU32_toWord32": t -> word;
-
- val null: t = fromWord 0w0
-
- fun isNull p = p = null
-
- (* val + = _prim "Pointer_add": t * t -> t; *)
- (* val op < = _prim "Pointer_lt": t * t -> bool; *)
- (* val - = _prim "Pointer_sub": t * t -> t; *)
-(* val free = _import "free": t -> unit; *)
- val getInt8 = _prim "Pointer_getWord8": t * int -> Int8.int;
- val getInt16 = _prim "Pointer_getWord16": t * int -> Int16.int;
- val getInt32 = _prim "Pointer_getWord32": t * int -> Int32.int;
- val getInt64 = _prim "Pointer_getWord64": t * int -> Int64.int;
- val getPointer = _prim "Pointer_getPointer": t * int -> 'a;
- val getReal32 = _prim "Pointer_getReal32": t * int -> Real32.real;
- val getReal64 = _prim "Pointer_getReal64": t * int -> Real64.real;
- val getWord8 = _prim "Pointer_getWord8": t * int -> Word8.word;
- val getWord16 = _prim "Pointer_getWord16": t * int -> Word16.word;
- val getWord32 = _prim "Pointer_getWord32": t * int -> Word32.word;
- val getWord64 = _prim "Pointer_getWord64": t * int -> Word64.word;
- val setInt8 = _prim "Pointer_setWord8": t * int * Int8.int -> unit;
- val setInt16 =
- _prim "Pointer_setWord16": t * int * Int16.int -> unit;
- val setInt32 =
- _prim "Pointer_setWord32": t * int * Int32.int -> unit;
- val setInt64 =
- _prim "Pointer_setWord64": t * int * Int64.int -> unit;
- val setPointer = _prim "Pointer_setPointer": t * int * 'a -> unit;
- val setReal32 =
- _prim "Pointer_setReal32": t * int * Real32.real -> unit;
- val setReal64 =
- _prim "Pointer_setReal64": t * int * Real64.real -> unit;
- val setWord8 =
- _prim "Pointer_setWord8": t * int * Word8.word -> unit;
- val setWord16 =
- _prim "Pointer_setWord16": t * int * Word16.word -> unit;
- val setWord32 =
- _prim "Pointer_setWord32": t * int * Word32.word -> unit;
- val setWord64 =
- _prim "Pointer_setWord64": t * int * Word64.word -> unit;
- end
-
- structure Real64 =
- struct
- open Real64
-
- structure Class =
- struct
- type t = int
-
- val inf = _const "IEEEReal_FloatClass_FP_INFINITE": t;
- val nan = _const "IEEEReal_FloatClass_FP_NAN": t;
- val normal = _const "IEEEReal_FloatClass_FP_NORMAL": t;
- val subnormal = _const "IEEEReal_FloatClass_FP_SUBNORMAL": t;
- val zero = _const "IEEEReal_FloatClass_FP_ZERO": t;
- end
-
- structure Math =
- struct
- type real = real
-
- val acos = _prim "Real64_Math_acos": real -> real;
- val asin = _prim "Real64_Math_asin": real -> real;
- val atan = _prim "Real64_Math_atan": real -> real;
- val atan2 = _prim "Real64_Math_atan2": real * real -> real;
- val cos = _prim "Real64_Math_cos": real -> real;
- val cosh = _import "cosh": real -> real;
- val e = #1 _symbol "Real64_Math_e": real GetSet.t; ()
- val exp = _prim "Real64_Math_exp": real -> real;
- val ln = _prim "Real64_Math_ln": real -> real;
- val log10 = _prim "Real64_Math_log10": real -> real;
- val pi = #1 _symbol "Real64_Math_pi": real GetSet.t; ()
- val pow = _import "pow": real * real -> real;
- val sin = _prim "Real64_Math_sin": real -> real;
- val sinh = _import "sinh": real -> real;
- val sqrt = _prim "Real64_Math_sqrt": real -> real;
- val tan = _prim "Real64_Math_tan": real -> real;
- val tanh = _import "tanh": real -> real;
- end
-
- val * = _prim "Real64_mul": real * real -> real;
- val *+ = _prim "Real64_muladd": real * real * real -> real;
- val *- = _prim "Real64_mulsub": real * real * real -> real;
- val + = _prim "Real64_add": real * real -> real;
- val - = _prim "Real64_sub": real * real -> real;
- val / = _prim "Real64_div": real * real -> real;
- val op < = _prim "Real64_lt": real * real -> bool;
- val op <= = _prim "Real64_le": real * real -> bool;
- val == = _prim "Real64_equal": real * real -> bool;
- val ?= = _prim "Real64_qequal": real * real -> bool;
- val abs = _prim "Real64_abs": real -> real;
- val class = _import "Real64_class": real -> int;
- val frexp = _import "Real64_frexp": real * int ref -> real;
- val gdtoa =
- _import "Real64_gdtoa": real * int * int * int ref -> CString.t;
- val fromInt = _prim "WordS32_toReal64": int -> real;
- val ldexp = _prim "Real64_ldexp": real * int -> real;
- val maxFinite = #1 _symbol "Real64_maxFinite": real GetSet.t; ()
- val minNormalPos = #1 _symbol "Real64_minNormalPos": real GetSet.t; ()
- val minPos = #1 _symbol "Real64_minPos": real GetSet.t; ()
- val modf = _import "Real64_modf": real * real ref -> real;
- val nextAfter = _import "Real64_nextAfter": real * real -> real;
- val round = _prim "Real64_round": real -> real;
- val signBit = _import "Real64_signBit": real -> int;
- val strto = _import "Real64_strto": NullString.t -> real;
- val toInt = _prim "Real64_toWordS32": real -> int;
- val ~ = _prim "Real64_neg": real -> real;
-
- val fromLarge : real -> real = fn x => x
- val toLarge : real -> real = fn x => x
- val precision : int = 53
- val radix : int = 2
- end
-
- structure Real32 =
- struct
- open Real32
-
- val precision : int = 24
- val radix : int = 2
-
- val fromLarge = _prim "Real64_toReal32": Real64.real -> real;
- val toLarge = _prim "Real32_toReal64": real -> Real64.real;
-
- fun unary (f: Real64.real -> Real64.real) (r: real): real =
- fromLarge (f (toLarge r))
-
- fun binary (f: Real64.real * Real64.real -> Real64.real)
- (r: real, r': real): real =
- fromLarge (f (toLarge r, toLarge r'))
-
- structure Math =
- struct
- type real = real
-
- val acos = _prim "Real32_Math_acos": real -> real;
- val asin = _prim "Real32_Math_asin": real -> real;
- val atan = _prim "Real32_Math_atan": real -> real;
- val atan2 = _prim "Real32_Math_atan2": real * real -> real;
- val cos = _prim "Real32_Math_cos": real -> real;
- val cosh = unary Real64.Math.cosh
- val e = #1 _symbol "Real32_Math_e": real GetSet.t; ()
- val exp = _prim "Real32_Math_exp": real -> real;
- val ln = _prim "Real32_Math_ln": real -> real;
- val log10 = _prim "Real32_Math_log10": real -> real;
- val pi = #1 _symbol "Real32_Math_pi": real GetSet.t; ()
- val pow = binary Real64.Math.pow
- val sin = _prim "Real32_Math_sin": real -> real;
- val sinh = unary Real64.Math.sinh
- val sqrt = _prim "Real32_Math_sqrt": real -> real;
- val tan = _prim "Real32_Math_tan": real -> real;
- val tanh = unary Real64.Math.tanh
- end
-
- val * = _prim "Real32_mul": real * real -> real;
- val *+ = _prim "Real32_muladd": real * real * real -> real;
- val *- = _prim "Real32_mulsub": real * real * real -> real;
- val + = _prim "Real32_add": real * real -> real;
- val - = _prim "Real32_sub": real * real -> real;
- val / = _prim "Real32_div": real * real -> real;
- val op < = _prim "Real32_lt": real * real -> bool;
- val op <= = _prim "Real32_le": real * real -> bool;
- val == = _prim "Real32_equal": real * real -> bool;
- val ?= = _prim "Real32_qequal": real * real -> bool;
- val abs = _prim "Real32_abs": real -> real;
- val class = _import "Real32_class": real -> int;
- fun frexp (r: real, ir: int ref): real =
- fromLarge (Real64.frexp (toLarge r, ir))
- val gdtoa =
- _import "Real32_gdtoa": real * int * int * int ref -> CString.t;
- val fromInt = _prim "WordS32_toReal32": int -> real;
- val ldexp = _prim "Real32_ldexp": real * int -> real;
- val maxFinite = #1 _symbol "Real32_maxFinite": real GetSet.t; ()
- val minNormalPos = #1 _symbol "Real32_minNormalPos": real GetSet.t; ()
- val minPos = #1 _symbol "Real32_minPos": real GetSet.t; ()
- val modf = _import "Real32_modf": real * real ref -> real;
- val signBit = _import "Real32_signBit": real -> int;
- val strto = _import "Real32_strto": NullString.t -> real;
- val toInt = _prim "Real32_toWordS32": real -> int;
- val ~ = _prim "Real32_neg": real -> real;
- end
-
- structure Real32 =
- struct
- open Real32
- local
- structure S = RealComparisons (Real32)
- in
- open S
- end
- end
-
- structure Real64 =
- struct
- open Real64
- local
- structure S = RealComparisons (Real64)
- in
- open S
- end
- end
-
- structure Ref =
- struct
- val deref = _prim "Ref_deref": 'a ref -> 'a;
- val assign = _prim "Ref_assign": 'a ref * 'a -> unit;
- end
-
- structure Status:
- sig
- eqtype t
-
- val failure: t
- val fromInt: int -> t
- val success: t
- val toInt: t -> int
- end =
- struct
- type t = int
-
- val failure = 1
- val fromInt = fn i => i
- val success = 0
- val toInt = fn i => i
- end
-
- val halt = _prim "MLton_halt": Status.t -> unit;
-
- structure String =
- struct
- val fromWord8Vector =
- _prim "Word8Vector_toString": Word8.word vector -> string;
- val toWord8Vector =
- _prim "String_toWord8Vector": string -> Word8.word vector;
- end
-
- structure TextIO =
- struct
- val bufSize = _command_line_const "TextIO.bufSize": int = 4096;
- end
-
- structure Thread =
- struct
- type preThread = PreThread.t
- type thread = Thread.t
-
- val atomicBegin = _prim "Thread_atomicBegin": unit -> unit;
- val canHandle = _prim "Thread_canHandle": unit -> int;
- fun atomicEnd () =
- if Int.<= (canHandle (), 0)
- then raise Fail "Thread.atomicEnd with no atomicBegin"
- else _prim "Thread_atomicEnd": unit -> unit; ()
- val copy = _prim "Thread_copy": preThread -> thread;
- (* copyCurrent's result is accesible via savedPre ().
- * It is not possible to have the type of copyCurrent as
- * unit -> preThread, because there are two different ways to
- * return from the call to copyCurrent. One way is the direct
- * obvious way, in the thread that called copyCurrent. That one,
- * of course, wants to call savedPre (). However, another way to
- * return is by making a copy of the preThread and then switching
- * to it. In that case, there is no preThread to return. Making
- * copyCurrent return a preThread creates nasty bugs where the
- * return code from the CCall expects to see a preThread result
- * according to the C return convention, but there isn't one when
- * switching to a copy.
- *)
- val copyCurrent = _prim "Thread_copyCurrent": unit -> unit;
- val current = _import "GC_getCurrentThread": GCState.t -> thread;
- val finishSignalHandler = _import "GC_finishSignalHandler": GCState.t -> unit;
- val returnToC = _prim "Thread_returnToC": unit -> unit;
- val saved = _import "GC_getSavedThread": GCState.t -> thread;
- val savedPre = _import "GC_getSavedThread": GCState.t -> preThread;
- val setCallFromCHandler =
- _import "GC_setCallFromCHandlerThread": GCState.t * thread -> unit;
- val setSignalHandler = _import "GC_setSignalHandlerThread": GCState.t * thread -> unit;
- val setSaved = _import "GC_setSavedThread": GCState.t * thread -> unit;
- val startSignalHandler = _import "GC_startSignalHandler": GCState.t -> unit;
- val switchTo = _prim "Thread_switchTo": thread -> unit;
- end
-
- structure TopLevel =
- struct
- val setHandler =
- _prim "TopLevel_setHandler": (exn -> unit) -> unit;
- val setSuffix =
- _prim "TopLevel_setSuffix": (unit -> unit) -> unit;
- end
-
- structure Vector =
- struct
- val sub = _prim "Vector_sub": 'a vector * int -> 'a;
- val length = _prim "Vector_length": 'a vector -> int;
-
- (* Don't mutate the array after you apply fromArray, because vectors
- * are supposed to be immutable and the optimizer depends on this.
- *)
- val fromArray = _prim "Array_toVector": 'a array -> 'a vector;
- end
-
- structure Word1 =
- struct
- open Word1
- type big = Word8.word
- val fromBigUnsafe = _prim "WordU8_toWord1": big -> word;
- val toBig = _prim "WordU1_toWord8": word -> big;
- val wordSize = 1
- end
- structure Word2 =
- struct
- open Word2
- type big = Word8.word
- val fromBigUnsafe = _prim "WordU8_toWord2": big -> word;
- val toBig = _prim "WordU2_toWord8": word -> big;
- val wordSize = 2
- end
- structure Word3 =
- struct
- open Word3
- type big = Word8.word
- val fromBigUnsafe = _prim "WordU8_toWord3": big -> word;
- val toBig = _prim "WordU3_toWord8": word -> big;
- val wordSize = 3
- end
- structure Word4 =
- struct
- open Word4
- type big = Word8.word
- val fromBigUnsafe = _prim "WordU8_toWord4": big -> word;
- val toBig = _prim "WordU4_toWord8": word -> big;
- val wordSize = 4
- end
- structure Word5 =
- struct
- open Word5
- type big = Word8.word
- val fromBigUnsafe = _prim "WordU8_toWord5": big -> word;
- val toBig = _prim "WordU5_toWord8": word -> big;
- val wordSize = 5
- end
- structure Word6 =
- struct
- open Word6
- type big = Word8.word
- val fromBigUnsafe = _prim "WordU8_toWord6": big -> word;
- val toBig = _prim "WordU6_toWord8": word -> big;
- val wordSize = 6
- end
- structure Word7 =
- struct
- open Word7
- type big = Word8.word
- val fromBigUnsafe = _prim "WordU8_toWord7": big -> word;
- val toBig = _prim "WordU7_toWord8": word -> big;
- val wordSize = 7
- end
- structure Word8 =
- struct
- open Word8
-
- val wordSize: int = 8
-
- val + = _prim "Word8_add": word * word -> word;
- val andb = _prim "Word8_andb": word * word -> word;
- val ~>> = _prim "WordS8_rshift": word * Word.word -> word;
- val div = _prim "WordU8_quot": word * word -> word;
- val fromInt = _prim "WordU32_toWord8": int -> word;
- val fromLarge = _prim "WordU64_toWord8": LargeWord.word -> word;
- val << = _prim "Word8_lshift": word * Word.word -> word;
- val op < = _prim "WordU8_lt": word * word -> bool;
- val mod = _prim "WordU8_rem": word * word -> word;
- val * = _prim "WordU8_mul": word * word -> word;
- val ~ = _prim "Word8_neg": word -> word;
- val notb = _prim "Word8_notb": word -> word;
- val orb = _prim "Word8_orb": word * word -> word;
- val rol = _prim "Word8_rol": word * Word.word -> word;
- val ror = _prim "Word8_ror": word * Word.word -> word;
- val >> = _prim "WordU8_rshift": word * Word.word -> word;
- val - = _prim "Word8_sub": word * word -> word;
- val toInt = _prim "WordU8_toWord32": word -> int;
- val toIntX = _prim "WordS8_toWord32": word -> int;
- val toLarge = _prim "WordU8_toWord64": word -> LargeWord.word;
- val toLargeX = _prim "WordS8_toWord64": word -> LargeWord.word;
- val xorb = _prim "Word8_xorb": word * word -> word;
- end
- structure Word8 =
- struct
- open Word8
- local
- structure S = Comparisons (Word8)
- in
- open S
- end
- end
- structure Word8Array =
- struct
- val subWord =
- _prim "Word8Array_subWord": Word8.word array * int -> word;
- val subWordRev =
- _import "Word8Array_subWord32Rev": Word8.word array * int -> word;
- val updateWord =
- _prim "Word8Array_updateWord": Word8.word array * int * word -> unit;
- val updateWordRev =
- _import "Word8Array_updateWord32Rev": Word8.word array * int * word -> unit;
- end
- structure Word8Vector =
- struct
- val subWord =
- _prim "Word8Vector_subWord": Word8.word vector * int -> word;
- val subWordRev =
- _import "Word8Vector_subWord32Rev": Word8.word vector * int -> word;
- end
- structure Word9 =
- struct
- open Word9
- type big = Word16.word
- val fromBigUnsafe = _prim "WordU16_toWord9": big -> word;
- val toBig = _prim "WordU9_toWord16": word -> big;
- val wordSize = 9
- end
- structure Word10 =
- struct
- open Word10
- type big = Word16.word
- val fromBigUnsafe = _prim "WordU16_toWord10": big -> word;
- val toBig = _prim "WordU10_toWord16": word -> big;
- val wordSize = 10
- end
- structure Word11 =
- struct
- open Word11
- type big = Word16.word
- val fromBigUnsafe = _prim "WordU16_toWord11": big -> word;
- val toBig = _prim "WordU11_toWord16": word -> big;
- val wordSize = 11
- end
- structure Word12 =
- struct
- open Word12
- type big = Word16.word
- val fromBigUnsafe = _prim "WordU16_toWord12": big -> word;
- val toBig = _prim "WordU12_toWord16": word -> big;
- val wordSize = 12
- end
- structure Word13 =
- struct
- open Word13
- type big = Word16.word
- val fromBigUnsafe = _prim "WordU16_toWord13": big -> word;
- val toBig = _prim "WordU13_toWord16": word -> big;
- val wordSize = 13
- end
- structure Word14 =
- struct
- open Word14
- type big = Word16.word
- val fromBigUnsafe = _prim "WordU16_toWord14": big -> word;
- val toBig = _prim "WordU14_toWord16": word -> big;
- val wordSize = 14
- end
- structure Word15 =
- struct
- open Word15
- type big = Word16.word
- val fromBigUnsafe = _prim "WordU16_toWord15": big -> word;
- val toBig = _prim "WordU15_toWord16": word -> big;
- val wordSize = 15
- end
- structure Word16 =
- struct
- open Word16
-
- val wordSize: int = 16
-
- val + = _prim "Word16_add": word * word -> word;
- val andb = _prim "Word16_andb": word * word -> word;
- val ~>> = _prim "WordS16_rshift": word * Word.word -> word;
- val div = _prim "WordU16_quot": word * word -> word;
- val fromInt = _prim "WordU32_toWord16": int -> word;
- val fromLarge = _prim "WordU64_toWord16": LargeWord.word -> word;
- val << = _prim "Word16_lshift": word * Word.word -> word;
- val op < = _prim "WordU16_lt": word * word -> bool;
- val mod = _prim "WordU16_rem": word * word -> word;
- val * = _prim "WordU16_mul": word * word -> word;
- val ~ = _prim "Word16_neg": word -> word;
- val notb = _prim "Word16_notb": word -> word;
- val orb = _prim "Word16_orb": word * word -> word;
- val >> = _prim "WordU16_rshift": word * Word.word -> word;
- val - = _prim "Word16_sub": word * word -> word;
- val toInt = _prim "WordU16_toWord32": word -> int;
- val toIntX = _prim "WordS16_toWord32": word -> int;
- val toLarge = _prim "WordU16_toWord64": word -> LargeWord.word;
- val toLargeX = _prim "WordS16_toWord64": word -> LargeWord.word;
- val xorb = _prim "Word16_xorb": word * word -> word;
-
- val toInt16 = _prim "WordU16_toWord16": word -> Int16.int;
- val fromInt16 = _prim "WordU16_toWord16": Int16.int -> word;
- end
- structure Word16 =
- struct
- open Word16
- local
- structure S = Comparisons (Word16)
- in
- open S
- end
- end
- structure Word17 =
- struct
- open Word17
- type big = Word32.word
- val fromBigUnsafe = _prim "WordU32_toWord17": big -> word;
- val toBig = _prim "WordU17_toWord32": word -> big;
- val wordSize = 17
- end
- structure Word18 =
- struct
- open Word18
- type big = Word32.word
- val fromBigUnsafe = _prim "WordU32_toWord18": big -> word;
- val toBig = _prim "WordU18_toWord32": word -> big;
- val wordSize = 18
- end
- structure Word19 =
- struct
- open Word19
- type big = Word32.word
- val fromBigUnsafe = _prim "WordU32_toWord19": big -> word;
- val toBig = _prim "WordU19_toWord32": word -> big;
- val wordSize = 19
- end
- structure Word20 =
- struct
- open Word20
- type big = Word32.word
- val fromBigUnsafe = _prim "WordU32_toWord20": big -> word;
- val toBig = _prim "WordU20_toWord32": word -> big;
- val wordSize = 20
- end
- structure Word21 =
- struct
- open Word21
- type big = Word32.word
- val fromBigUnsafe = _prim "WordU32_toWord21": big -> word;
- val toBig = _prim "WordU21_toWord32": word -> big;
- val wordSize = 21
- end
- structure Word22 =
- struct
- open Word22
- type big = Word32.word
- val fromBigUnsafe = _prim "WordU32_toWord22": big -> word;
- val toBig = _prim "WordU22_toWord32": word -> big;
- val wordSize = 22
- end
- structure Word23 =
- struct
- open Word23
- type big = Word32.word
- val fromBigUnsafe = _prim "WordU32_toWord23": big -> word;
- val toBig = _prim "WordU23_toWord32": word -> big;
- val wordSize = 23
- end
- structure Word24 =
- struct
- open Word24
- type big = Word32.word
- val fromBigUnsafe = _prim "WordU32_toWord24": big -> word;
- val toBig = _prim "WordU24_toWord32": word -> big;
- val wordSize = 24
- end
- structure Word25 =
- struct
- open Word25
- type big = Word32.word
- val fromBigUnsafe = _prim "WordU32_toWord25": big -> word;
- val toBig = _prim "WordU25_toWord32": word -> big;
- val wordSize = 25
- end
- structure Word26 =
- struct
- open Word26
- type big = Word32.word
- val fromBigUnsafe = _prim "WordU32_toWord26": big -> word;
- val toBig = _prim "WordU26_toWord32": word -> big;
- val wordSize = 26
- end
- structure Word27 =
- struct
- open Word27
- type big = Word32.word
- val fromBigUnsafe = _prim "WordU32_toWord27": big -> word;
- val toBig = _prim "WordU27_toWord32": word -> big;
- val wordSize = 27
- end
- structure Word28 =
- struct
- open Word28
- type big = Word32.word
- val fromBigUnsafe = _prim "WordU32_toWord28": big -> word;
- val toBig = _prim "WordU28_toWord32": word -> big;
- val wordSize = 28
- end
- structure Word29 =
- struct
- open Word29
- type big = Word32.word
- val fromBigUnsafe = _prim "WordU32_toWord29": big -> word;
- val toBig = _prim "WordU29_toWord32": word -> big;
- val wordSize = 29
- end
- structure Word30 =
- struct
- open Word30
- type big = Word32.word
- val fromBigUnsafe = _prim "WordU32_toWord30": big -> word;
- val toBig = _prim "WordU30_toWord32": word -> big;
- val wordSize = 30
- end
- structure Word31 =
- struct
- open Word31
- type big = Word32.word
- val fromBigUnsafe = _prim "WordU32_toWord31": big -> word;
- val toBig = _prim "WordU31_toWord32": word -> big;
- val wordSize = 31
- end
- structure Word32 =
- struct
- open Word32
-
- val wordSize: int = 32
-
- val + = _prim "Word32_add": word * word -> word;
- val andb = _prim "Word32_andb": word * word -> word;
- val ~>> = _prim "WordS32_rshift": word * word -> word;
- val div = _prim "WordU32_quot": word * word -> word;
- val fromInt = _prim "WordU32_toWord32": int -> word;
- val fromLarge = _prim "WordU64_toWord32": LargeWord.word -> word;
- val << = _prim "Word32_lshift": word * word -> word;
- val op < = _prim "WordU32_lt": word * word -> bool;
- val mod = _prim "WordU32_rem": word * word -> word;
- val * = _prim "WordU32_mul": word * word -> word;
- val ~ = _prim "Word32_neg": word -> word;
- val notb = _prim "Word32_notb": word -> word;
- val orb = _prim "Word32_orb": word * word -> word;
- val rol = _prim "Word32_rol": word * word -> word;
- val ror = _prim "Word32_ror": word * word -> word;
- val >> = _prim "WordU32_rshift": word * word -> word;
- val - = _prim "Word32_sub": word * word -> word;
- val toInt = _prim "WordU32_toWord32": word -> int;
- val toIntX = _prim "WordS32_toWord32": word -> int;
- val toLarge = _prim "WordU32_toWord64": word -> LargeWord.word;
- val toLargeX = _prim "WordS32_toWord64": word -> LargeWord.word;
- val xorb = _prim "Word32_xorb": word * word -> word;
-
- val toInt32 = _prim "WordU32_toWord32": word -> Int32.int;
- val fromInt32 = _prim "WordU32_toWord32": Int32.int -> word;
- end
- structure Word32 =
- struct
- open Word32
- local
- structure S = Comparisons (Word32)
- in
- open S
- end
- end
- structure Word = Word32
- structure Word64 =
- struct
- open Word64
-
- val wordSize: int = 64
-
- val + = _prim "Word64_add": word * word -> word;
- val andb = _prim "Word64_andb": word * word -> word;
- val ~>> = _prim "WordS64_rshift": word * Word.word -> word;
- val div = _prim "WordU64_quot": word * word -> word;
- val fromInt = _prim "WordS32_toWord64": int -> word;
- val fromLarge: LargeWord.word -> word = fn x => x
- val << = _prim "Word64_lshift": word * Word.word -> word;
- val op < = _prim "WordU64_lt": word * word -> bool;
- val mod = _prim "WordU64_rem": word * word -> word;
- val * = _prim "WordU64_mul": word * word -> word;
- val ~ = _prim "Word64_neg": word -> word;
- val notb = _prim "Word64_notb": word -> word;
- val orb = _prim "Word64_orb": word * word -> word;
- val >> = _prim "WordU64_rshift": word * Word.word -> word;
- val - = _prim "Word64_sub": word * word -> word;
- val toInt = _prim "WordU64_toWord32": word -> int;
- val toIntX = _prim "WordU64_toWord32": word -> int;
- val toLarge: word -> LargeWord.word = fn x => x
- val toLargeX: word -> LargeWord.word = fn x => x
- val xorb = _prim "Word64_xorb": word * word -> word;
- end
- structure Word64 =
- struct
- open Word64
- local
- structure S = Comparisons (Word64)
- in
- open S
- end
- end
-
- structure Cygwin =
- struct
- val toFullWindowsPath =
- _import "Cygwin_toFullWindowsPath": NullString.t -> CString.t;
- end
-
- structure FileDesc:
- sig
- eqtype t
-
- val fromWord: word -> t
- val fromInt: int -> t
- val toInt: t -> int
- val toWord: t -> word
- end =
- struct
- type t = int
-
- val fromWord = Word32.toInt
- fun fromInt i = i
- fun toInt i = i
- val toWord = Word32.fromInt
- end
-
- structure World =
- struct
- val getAmOriginal = _import "GC_getAmOriginal": GCState.t -> bool;
- val setAmOriginal = _import "GC_setAmOriginal": GCState.t * bool -> unit;
- val save = _prim "World_save": FileDesc.t -> unit;
- end
- end
-
-structure Primitive =
- struct
- open Primitive
-
- structure Int32 =
- struct
- open Int32
-
- local
- fun make f (i: int, i': int): bool =
- f (Primitive.Word32.fromInt i, Primitive.Word32.fromInt i')
- in
- val geu = make Primitive.Word32.>=
- val gtu = make Primitive.Word32.>
- end
- end
- structure Int = Int32
- end
-
-structure NullString =
- struct
- open NullString
-
- fun fromString s =
- if #"\000" = let
- open Primitive
- in
- Vector.sub (s, Int.- (Vector.length s, 1))
- end
- then NullString.fromString s
- else raise Fail "NullString.fromString"
-
- val empty = fromString "\000"
- end
-structure NullString8 = NullString
-structure NullString8Array = struct type t = NullString8.t array end
-
-(* Quell unused warnings. *)
-local
- val _ = #"a": Char16.t: Char16.char
- val _ = #"a": Char32.t: Char32.char
- val _ = "a": String16.t: String16.string
- val _ = "a": String32.t: String32.string
- open Primitive
- open Char2
- val _ = op <
- val _ = chr
- val _ = ord
- open Char4
- val _ = op <
- val _ = chr
- val _ = ord
- open Int64
- val _ = <<
- val _ = >>
- val _ = ~>>
- val _ = andb
-in
-end
-
-(* Install an emergency exception handler. *)
-local
- open Primitive
- val _ =
- TopLevel.setHandler
- (fn exn =>
- (Stdio.print "unhandled exception: "
- ; case exn of
- Fail msg => (Stdio.print "Fail "
- ; Stdio.print msg)
- | _ => Stdio.print (Exn.name exn)
- ; Stdio.print "\n"
- ; bug (NullString.fromString
- "unhandled exception in Basis Library\000")))
-in
-end
-
-val op + = Primitive.Int.+
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/real/IEEE-real.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/real/IEEE-real.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/real/IEEE-real.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -34,5 +34,6 @@
sig
include IEEE_REAL
+ val mkClass: ('a -> C_Int.t) -> 'a -> float_class
val withRoundingMode: rounding_mode * (unit -> 'a) -> 'a
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/real/IEEE-real.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/real/IEEE-real.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/real/IEEE-real.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -15,15 +15,40 @@
exception Unordered
datatype real_order = LESS | EQUAL | GREATER | UNORDERED
+ structure Prim = PrimitiveFFI.IEEEReal
+
datatype float_class =
INF
| NAN
| NORMAL
| SUBNORMAL
| ZERO
-
- structure Prim = PrimitiveFFI.IEEEReal
+ local
+ val classes =
+ let
+ open Prim.FloatClass
+ in
+ (* order here is chosen based on putting the more
+ * commonly used classes at the front.
+ *)
+ [(FP_NORMAL, NORMAL),
+ (FP_ZERO, ZERO),
+ (FP_INFINITE, INF),
+ (FP_NAN, NAN),
+ (FP_SUBNORMAL, SUBNORMAL)]
+ end
+ in
+ fun mkClass class x =
+ let
+ val i = class x
+ in
+ case List.find (fn (i', _) => i = i') classes of
+ NONE => raise Fail "Real_class returned bogus integer"
+ | SOME (_, c) => c
+ end
+ end
+
structure RoundingMode =
struct
datatype t =
@@ -43,13 +68,13 @@
(FE_TOWARDZERO, TO_ZERO)]
end
in
- val fromInt: int -> t =
+ val fromInt: C_Int.int -> t =
fn i =>
case List.find (fn (i', _) => i = i') modes of
NONE => raise Fail "IEEEReal.RoundingMode.fromInt"
| SOME (_, m) => m
- val toInt: t -> int =
+ val toInt: t -> C_Int.int =
fn m =>
let
open Prim.RoundingMode
@@ -151,8 +176,7 @@
type exp = {digits: int list, negate: bool}
fun 'b afterE (state: 'a,
failure: unit -> 'b,
- success: exp * 'a -> 'b)
- : 'b =
+ success: exp * 'a -> 'b) : 'b =
case reader state of
NONE => failure ()
| SOME (c, state) =>
@@ -373,4 +397,3 @@
else num
end
end
-
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/real/pack-real.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/real/pack-real.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/real/pack-real.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -8,85 +8,244 @@
functor PackReal (S: sig
type real
- val bytesPerElem: int
+ val realSize: int
val isBigEndian: bool
- val subVec: Word8.word vector * int -> real
- val subVecRev: Word8.word vector * int -> real
- val update: Word8.word array * int * real -> unit
- val updateRev: Word8.word array * int * real -> unit
+ val subArr: Word8.word array * C_Ptrdiff.t -> real
+ val subArrRev: Word8.word array * C_Ptrdiff.t -> real
+ val subVec: Word8.word vector * C_Ptrdiff.t -> real
+ val subVecRev: Word8.word vector * C_Ptrdiff.t -> real
+ val update: Word8.word array * C_Ptrdiff.t * real -> unit
+ val updateRev: Word8.word array * C_Ptrdiff.t * real -> unit
end): PACK_REAL =
struct
open S
-val (sub, up) =
+val bytesPerElem = Int.div (realSize, 8)
+
+val (subA, subV, updA) =
if isBigEndian = Primitive.MLton.Platform.Arch.hostIsBigEndian
- then (subVec, update)
- else (subVecRev, updateRev)
+ then (subArr, subVec, update)
+ else (subArrRev, subVecRev, updateRev)
fun offset (i, n) =
let
val i = Int.* (bytesPerElem, i)
val () =
- if Primitive.safe
- andalso (Primitive.Int.geu
- (Int.+ (i, Int.- (bytesPerElem, 1)), n)) then
- raise Subscript
- else
- ()
+ if Primitive.Controls.safe
+ andalso (Int.geu (Int.+ (i, Int.- (bytesPerElem, 1)), n))
+ then raise Subscript
+ else ()
in
- i
- end handle Overflow => raise Subscript
+ C_Ptrdiff.fromInt i
+ end
+ handle Overflow => raise Subscript
fun update (a, i, r) =
let
val i = offset (i, Word8Array.length a)
val a = Word8Array.toPoly a
in
- up (a, i, r)
+ updA (a, i, r)
end
local
- val a = Word8Array.array (bytesPerElem, 0w0)
+ val a = Array.arrayUninit bytesPerElem
in
fun toBytes (r: real): Word8Vector.vector =
- (up (Word8Array.toPoly a, 0, r)
- ; Byte.stringToBytes (Byte.unpackString (Word8ArraySlice.full a)))
+ (updA (a, 0, r)
+ ; Word8Vector.fromPoly (Vector.fromArray a))
end
-fun subVec (v, i) =
- let
- val i = offset (i, Word8Vector.length v)
- val v = Word8Vector.toPoly v
- in
- sub (v, i)
- end
+local
+ fun make (sub, length, toPoly) (s, i) =
+ let
+ val i = offset (i, length s)
+ val s = toPoly s
+ in
+ sub (s, i)
+ end
+in
+ val subArr = make (subA, Word8Array.length, Word8Array.toPoly)
+ val subVec = make (subV, Word8Vector.length, Word8Vector.toPoly)
+end
fun fromBytes v = subVec (v, 0)
-fun subArr (a, i) =
- subVec (Word8Vector.fromPoly
- (Primitive.Vector.fromArray (Word8Array.toPoly a)),
- i)
-
end
structure PackReal32Big: PACK_REAL =
- PackReal (val bytesPerElem: int = 4
+ PackReal (val realSize = Real32.realSize
val isBigEndian = true
open Primitive.PackReal32)
structure PackReal32Little: PACK_REAL =
- PackReal (val bytesPerElem: int = 4
+ PackReal (val realSize = Real32.realSize
val isBigEndian = false
open Primitive.PackReal32)
structure PackReal64Big: PACK_REAL =
- PackReal (val bytesPerElem: int = 8
+ PackReal (val realSize = Real64.realSize
val isBigEndian = true
open Primitive.PackReal64)
structure PackReal64Little: PACK_REAL =
- PackReal (val bytesPerElem: int = 8
+ PackReal (val realSize = Real64.realSize
val isBigEndian = false
open Primitive.PackReal64)
+local
+ local
+ structure S =
+ Real_ChooseRealN
+ (type 'a t = int
+ val fReal32 = Real32.realSize
+ val fReal64 = Real64.realSize)
+ in
+ val realSize = S.f
+ end
+ structure PackReal =
+ struct
+ type real = Real.real
+ local
+ structure S =
+ Real_ChooseRealN
+ (type 'a t = Word8.word array * C_Ptrdiff.t -> 'a
+ val fReal32 = Primitive.PackReal32.subArr
+ val fReal64 = Primitive.PackReal64.subArr)
+ in
+ val subArr = S.f
+ end
+ local
+ structure S =
+ Real_ChooseRealN
+ (type 'a t = Word8.word array * C_Ptrdiff.t -> 'a
+ val fReal32 = Primitive.PackReal32.subArrRev
+ val fReal64 = Primitive.PackReal64.subArrRev)
+ in
+ val subArrRev = S.f
+ end
+ local
+ structure S =
+ Real_ChooseRealN
+ (type 'a t = Word8.word vector * C_Ptrdiff.t -> 'a
+ val fReal32 = Primitive.PackReal32.subVec
+ val fReal64 = Primitive.PackReal64.subVec)
+ in
+ val subVec = S.f
+ end
+ local
+ structure S =
+ Real_ChooseRealN
+ (type 'a t = Word8.word vector * C_Ptrdiff.t -> 'a
+ val fReal32 = Primitive.PackReal32.subVecRev
+ val fReal64 = Primitive.PackReal64.subVecRev)
+ in
+ val subVecRev = S.f
+ end
+ local
+ structure S =
+ Real_ChooseRealN
+ (type 'a t = Word8.word array * C_Ptrdiff.t * 'a -> unit
+ val fReal32 = Primitive.PackReal32.update
+ val fReal64 = Primitive.PackReal64.update)
+ in
+ val update = S.f
+ end
+ local
+ structure S =
+ Real_ChooseRealN
+ (type 'a t = Word8.word array * C_Ptrdiff.t * 'a -> unit
+ val fReal32 = Primitive.PackReal32.updateRev
+ val fReal64 = Primitive.PackReal64.updateRev)
+ in
+ val updateRev = S.f
+ end
-structure PackRealBig = PackReal64Big
-structure PackRealLittle = PackReal64Little
+ end
+in
+structure PackRealBig: PACK_REAL =
+ PackReal (val realSize = realSize
+ val isBigEndian = true
+ open PackReal)
+structure PackRealLittle: PACK_REAL =
+ PackReal (val realSize = realSize
+ val isBigEndian = false
+ open PackReal)
+end
+local
+ local
+ structure S =
+ LargeReal_ChooseRealN
+ (type 'a t = int
+ val fReal32 = Real32.realSize
+ val fReal64 = Real64.realSize)
+ in
+ val realSize = S.f
+ end
+
+ structure PackLargeReal =
+ struct
+ type real = LargeReal.real
+ local
+ structure S =
+ LargeReal_ChooseRealN
+ (type 'a t = Word8.word array * C_Ptrdiff.t -> 'a
+ val fReal32 = Primitive.PackReal32.subArr
+ val fReal64 = Primitive.PackReal64.subArr)
+ in
+ val subArr = S.f
+ end
+ local
+ structure S =
+ LargeReal_ChooseRealN
+ (type 'a t = Word8.word array * C_Ptrdiff.t -> 'a
+ val fReal32 = Primitive.PackReal32.subArrRev
+ val fReal64 = Primitive.PackReal64.subArrRev)
+ in
+ val subArrRev = S.f
+ end
+ local
+ structure S =
+ LargeReal_ChooseRealN
+ (type 'a t = Word8.word vector * C_Ptrdiff.t -> 'a
+ val fReal32 = Primitive.PackReal32.subVec
+ val fReal64 = Primitive.PackReal64.subVec)
+ in
+ val subVec = S.f
+ end
+ local
+ structure S =
+ LargeReal_ChooseRealN
+ (type 'a t = Word8.word vector * C_Ptrdiff.t -> 'a
+ val fReal32 = Primitive.PackReal32.subVecRev
+ val fReal64 = Primitive.PackReal64.subVecRev)
+ in
+ val subVecRev = S.f
+ end
+ local
+ structure S =
+ LargeReal_ChooseRealN
+ (type 'a t = Word8.word array * C_Ptrdiff.t * 'a -> unit
+ val fReal32 = Primitive.PackReal32.update
+ val fReal64 = Primitive.PackReal64.update)
+ in
+ val update = S.f
+ end
+ local
+ structure S =
+ LargeReal_ChooseRealN
+ (type 'a t = Word8.word array * C_Ptrdiff.t * 'a -> unit
+ val fReal32 = Primitive.PackReal32.updateRev
+ val fReal64 = Primitive.PackReal64.updateRev)
+ in
+ val updateRev = S.f
+ end
+
+ end
+in
+structure PackLargeRealBig: PACK_REAL =
+ PackReal (val realSize = realSize
+ val isBigEndian = true
+ open PackLargeReal)
+structure PackLargeRealLittle: PACK_REAL =
+ PackReal (val realSize = realSize
+ val isBigEndian = false
+ open PackLargeReal)
+end
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/real/real-global.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real-global.sml)
Deleted: mlton/branches/on-20050822-x86_64-branch/basis-library/real/real.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/real/real.fun 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/real/real.fun 2006-05-06 18:44:35 UTC (rev 4468)
@@ -1,777 +0,0 @@
-(* Copyright (C) 2003-2005 Henry Cejtin, Matthew Fluet, Suresh
- * Jagannathan, and Stephen Weeks.
- *
- * MLton is released under a BSD-style license.
- * See the file MLton-LICENSE for details.
- *)
-
-functor Real (R: PRE_REAL): REAL =
- struct
- structure MLton = Primitive.MLton
- structure Prim = R
- local
- open IEEEReal
- in
- datatype z = datatype float_class
- datatype rounding_mode = datatype rounding_mode
- end
- infix 4 == != ?=
- type real = Prim.real
-
- local
- open Prim
- val isBytecode = MLton.Codegen.isBytecode
- in
- val *+ =
- if isBytecode
- then fn (r1, r2, r3) => r1 * r2 + r3
- else *+
- val *- =
- if isBytecode
- then fn (r1, r2, r3) => r1 * r2 - r3
- else *-
- val op * = op *
- val op + = op +
- val op - = op -
- val op / = op /
- val op / = op /
- val op < = op <
- val op <= = op <=
- val op > = op >
- val op >= = op >=
- val ~ = ~
- val abs = abs
- val fromInt = fromInt
- val fromLarge = fromLarge
- val maxFinite = maxFinite
- val minNormalPos = minNormalPos
- val minPos = minPos
- val precision = precision
- val radix = radix
- val signBit = fn r => signBit r <> 0
- val toLarge = toLarge
- end
-
- val zero = fromLarge TO_NEAREST 0.0
- val one = fromLarge TO_NEAREST 1.0
- val negOne = ~ one
- val two = fromLarge TO_NEAREST 2.0
- val half = one / two
-
- val posInf = one / zero
- val negInf = ~one / zero
-
- val nan = posInf + negInf
-
- structure Class = Primitive.Real64.Class
- local
- val classes =
- let
- open Class
- in
- (* order here is chosen based on putting the more commonly used
- * classes at the front.
- *)
- [(normal, NORMAL),
- (zero, ZERO),
- (inf, INF),
- (nan, NAN),
- (subnormal, SUBNORMAL)]
- end
- in
- fun class x =
- let
- val i = Prim.class x
- in
- case List.find (fn (i', _) => i = i') classes of
- NONE => raise Fail "Real_class returned bogus integer"
- | SOME (_, c) => c
- end
- end
-
- val abs =
- if MLton.Codegen.isNative
- then abs
- else
- fn x =>
- case class x of
- INF => posInf
- | NAN => x
- | _ => if signBit x then ~x else x
-
- fun isFinite r =
- case class r of
- INF => false
- | NAN => false
- | _ => true
-
- val op == = Prim.==
-
- val op != = not o op ==
-
- fun isNan r = r != r
-
- fun isNormal r = class r = NORMAL
-
- val op ?= =
- if MLton.Codegen.isNative
- then Prim.?=
- else
- fn (x, y) =>
- case (class x, class y) of
- (NAN, _) => true
- | (_, NAN) => true
- | (ZERO, ZERO) => true
- | _ => Prim.== (x, y)
-
- fun min (x, y) =
- if isNan x
- then y
- else if isNan y
- then x
- else if x < y then x else y
-
- fun max (x, y) =
- if isNan x
- then y
- else if isNan y
- then x
- else if x > y then x else y
-
- fun sign (x: real): int =
- case class x of
- NAN => raise Domain
- | ZERO => 0
- | _ => if x > zero then 1 else ~1
-
- fun sameSign (x, y) = signBit x = signBit y
-
- fun copySign (x, y) =
- if sameSign (x, y)
- then x
- else ~ x
-
- local
- datatype z = datatype IEEEReal.real_order
- in
- fun compareReal (x, y) =
- case (class x, class y) of
- (NAN, _) => UNORDERED
- | (_, NAN) => UNORDERED
- | (ZERO, ZERO) => EQUAL
- | _ => if x < y then LESS
- else if x > y then GREATER
- else EQUAL
- end
-
- local
- structure I = IEEEReal
- structure G = General
- in
- fun compare (x, y) =
- case compareReal (x, y) of
- I.EQUAL => G.EQUAL
- | I.GREATER => G.GREATER
- | I.LESS => G.LESS
- | I.UNORDERED => raise IEEEReal.Unordered
- end
-
- fun unordered (x, y) = isNan x orelse isNan y
-
- val nextAfter: real * real -> real =
- fn (r, t) =>
- case (class r, class t) of
- (NAN, _) => nan
- | (_, NAN) => nan
- | (INF, _) => r
- | (ZERO, ZERO) => r
- | (ZERO, _) => if t > zero then minPos else ~minPos
- | _ =>
- if r == t
- then r
- else
- let
- fun doit (r, t) =
- if r == maxFinite andalso t == posInf
- then posInf
- else if r > t
- then R.nextAfterDown r
- else R.nextAfterUp r
- in
- if r > zero
- then doit (r, t)
- else ~ (doit (~r, ~t))
- end
-
- val toManExp =
- let
- val r: int ref = ref 0
- in
- fn x =>
- case class x of
- INF => {exp = 0, man = x}
- | NAN => {exp = 0, man = nan}
- | ZERO => {exp = 0, man = x}
- | _ =>
- let
- val man = Prim.frexp (x, r)
- in
- {exp = !r, man = man}
- end
- end
-
- fun fromManExp {exp, man} = Prim.ldexp (man, exp)
-
- val fromManExp =
- if MLton.Codegen.isNative
- then fromManExp
- else
- fn {exp, man} =>
- case class man of
- INF => man
- | NAN => man
- | ZERO => man
- | _ => fromManExp {exp = exp, man = man}
-
- local
- val int = ref zero
- in
- fun split x =
- case class x of
- INF => {frac = if x > zero then zero else ~zero,
- whole = x}
- | NAN => {frac = nan, whole = nan}
- | _ =>
- let
- val frac = Prim.modf (x, int)
- val whole = !int
- (* Some platforms' C libraries don't get sign of zero right.
- *)
- fun fix y =
- if class y = ZERO
- andalso not (sameSign (x, y))
- then ~ y
- else y
- in
- {frac = fix frac,
- whole = fix whole}
- end
- end
-
- val realMod = #frac o split
-
- fun checkFloat x =
- case class x of
- INF => raise Overflow
- | NAN => raise Div
- | _ => x
-
- val maxInt = fromInt Int.maxInt'
- val minInt = fromInt Int.minInt'
-
- fun roundReal (x: real, m: rounding_mode): real =
- fromLarge
- TO_NEAREST
- (IEEEReal.withRoundingMode (m, fn () =>
- (Primitive.Real64.round (toLarge x))))
-
- fun toInt mode x =
- case class x of
- INF => raise Overflow
- | NAN => raise Domain
- | _ =>
- if minInt <= x
- then if x <= maxInt
- then Prim.toInt (roundReal (x, mode))
- else if x < maxInt + one
- then (case mode of
- TO_NEGINF => Int.maxInt'
- | TO_POSINF => raise Overflow
- | TO_ZERO => Int.maxInt'
- | TO_NEAREST =>
- (* Depends on maxInt being odd. *)
- if x - maxInt >= half
- then raise Overflow
- else Int.maxInt')
- else raise Overflow
- else if x > minInt - one
- then (case mode of
- TO_NEGINF => raise Overflow
- | TO_POSINF => Int.minInt'
- | TO_ZERO => Int.minInt'
- | TO_NEAREST =>
- (* Depends on minInt being even. *)
- if x - minInt < ~half
- then raise Overflow
- else Int.minInt')
- else raise Overflow
-
- val floor = toInt TO_NEGINF
- val ceil = toInt TO_POSINF
- val trunc = toInt TO_ZERO
- val round = toInt TO_NEAREST
-
- local
- fun round mode x =
- case class x of
- INF => x
- | NAN => x
- | _ => roundReal (x, mode)
- in
- val realCeil = round TO_POSINF
- val realFloor = round TO_NEGINF
- val realRound = round TO_NEAREST
- val realTrunc = round TO_ZERO
- end
-
- fun rem (x, y) =
- case class x of
- INF => nan
- | NAN => nan
- | ZERO => zero
- | _ =>
- case class y of
- INF => x
- | NAN => nan
- | ZERO => nan
- | _ => x - realTrunc (x/y) * y
-
- (* fromDecimal, scan, fromString: decimal -> binary conversions *)
- exception Bad
- fun fromDecimal ({class, digits, exp, sign}: IEEEReal.decimal_approx) =
- let
- fun doit () =
- let
- val exp =
- if Int.< (exp, 0)
- then concat ["-", Int.toString (Int.~ exp)]
- else Int.toString exp
-(* val x = concat ["0.", digits, "E", exp, "\000"] *)
- val n =
- Int.+ (4, Int.+ (List.length digits, String.size exp))
- val a = Array.rawArray n
- fun up (i, c) = (Array.update (a, i, c); Int.+ (i, 1))
- val i = 0
- val i = up (i, #"0")
- val i = up (i, #".")
- val i =
- List.foldl
- (fn (d, i) =>
- if Int.< (d, 0) orelse Int.> (d, 9)
- then raise Bad
- else up (i, Char.chr (Int.+ (d, Char.ord #"0"))))
- i digits
- val i = up (i, #"E")
- val i = CharVector.foldl (fn (c, i) => up (i, c)) i exp
- val _ = up (i, #"\000")
- val x = Vector.fromArray a
- val x = Prim.strto (NullString.fromString x)
- in
- if sign
- then ~ x
- else x
- end
- in
- SOME (case class of
- INF => if sign then negInf else posInf
- | NAN => nan
- | NORMAL => doit ()
- | SUBNORMAL => doit ()
- | ZERO => if sign then ~ zero else zero)
- handle Bad => NONE
- end
-
- fun scan reader state =
- case IEEEReal.scan reader state of
- NONE => NONE
- | SOME (da, state) => SOME (valOf (fromDecimal da), state)
-
- val fromString = StringCvt.scanString scan
-
- (* toDecimal, fmt, toString: binary -> decimal conversions. *)
- datatype mode = Fix | Gen | Sci
- local
- val decpt: int ref = ref 0
- in
- fun gdtoa (x: real, mode: mode, ndig: int) =
- let
- val mode =
- case mode of
- Fix => 3
- | Gen => 0
- | Sci => 2
- val cs = Prim.gdtoa (x, mode, ndig, decpt)
- in
- (cs, !decpt)
- end
- end
-
- fun toDecimal (x: real): IEEEReal.decimal_approx =
- case class x of
- INF => {class = INF,
- digits = [],
- exp = 0,
- sign = x < zero}
- | NAN => {class = NAN,
- digits = [],
- exp = 0,
- sign = false}
- | ZERO => {class = ZERO,
- digits = [],
- exp = 0,
- sign = signBit x}
- | c =>
- let
- val (cs, exp) = gdtoa (x, Gen, 0)
- fun loop (i, ac) =
- if Int.< (i, 0)
- then ac
- else loop (Int.- (i, 1),
- (Int.- (Char.ord (COld.CS.sub (cs, i)),
- Char.ord #"0"))
- :: ac)
- val digits = loop (Int.- (COld.CS.length cs, 1), [])
- in
- {class = c,
- digits = digits,
- exp = exp,
- sign = x < zero}
- end
-
- datatype realfmt = datatype StringCvt.realfmt
-
- fun add1 n = Int.+ (n, 1)
-
- local
- fun fix (sign: string, cs: COld.CS.t, decpt: int, ndig: int): string =
- let
- val length = COld.CS.length cs
- in
- if Int.< (decpt, 0)
- then
- concat [sign,
- "0.",
- String.new (Int.~ decpt, #"0"),
- COld.CS.toString cs,
- String.new (Int.+ (Int.- (ndig, length),
- decpt),
- #"0")]
- else
- let
- val whole =
- if decpt = 0
- then "0"
- else
- String.tabulate (decpt, fn i =>
- if Int.< (i, length)
- then COld.CS.sub (cs, i)
- else #"0")
- in
- if 0 = ndig
- then concat [sign, whole]
- else
- let
- val frac =
- String.tabulate
- (ndig, fn i =>
- let
- val j = Int.+ (i, decpt)
- in
- if Int.< (j, length)
- then COld.CS.sub (cs, j)
- else #"0"
- end)
- in
- concat [sign, whole, ".", frac]
- end
- end
- end
- fun sci (x: real, ndig: int): string =
- let
- val sign = if x < zero then "~" else ""
- val (cs, decpt) = gdtoa (x, Sci, add1 ndig)
- val length = COld.CS.length cs
- val whole = String.tabulate (1, fn _ => COld.CS.sub (cs, 0))
- val frac =
- if 0 = ndig
- then ""
- else concat [".",
- String.tabulate
- (ndig, fn i =>
- let
- val j = Int.+ (i, 1)
- in
- if Int.< (j, length)
- then COld.CS.sub (cs, j)
- else #"0"
- end)]
- val exp = Int.- (decpt, 1)
- val exp =
- let
- val (exp, sign) =
- if Int.< (exp, 0)
- then (Int.~ exp, "~")
- else (exp, "")
- in
- concat [sign, Int.toString exp]
- end
- in
- concat [sign, whole, frac, "E", exp]
- end
- fun gen (x: real, n: int): string =
- case class x of
- INF => if x > zero then "inf" else "~inf"
- | NAN => "nan"
- | _ =>
- let
- val (prefix, x) =
- if x < zero
- then ("~", ~ x)
- else ("", x)
- val ss = Substring.full (sci (x, Int.- (n, 1)))
- fun isE c = c = #"E"
- fun isZero c = c = #"0"
- val expS =
- Substring.string (Substring.taker (not o isE) ss)
- val exp = valOf (Int.fromString expS)
- val man =
- String.translate
- (fn #"." => "" | c => str c)
- (Substring.string (Substring.dropr isZero
- (Substring.takel (not o isE) ss)))
- val manSize = String.size man
- fun zeros i = CharVector.tabulate (i, fn _ => #"0")
- fun dotAt i =
- concat [String.substring (man, 0, i),
- ".", String.extract (man, i, NONE)]
- fun sci () = concat [prefix,
- if manSize = 1 then man else dotAt 1,
- "E", expS]
- val op - = Int.-
- val op + = Int.+
- val ~ = Int.~
- val op >= = Int.>=
- in
- if exp >= (if manSize = 1 then 3 else manSize + 3)
- then sci ()
- else if exp >= manSize - 1
- then concat [prefix, man, zeros (exp - (manSize - 1))]
- else if exp >= 0
- then concat [prefix, dotAt (exp + 1)]
- else if exp >= (if manSize = 1 then ~2 else ~3)
- then concat [prefix, "0.", zeros (~exp - 1), man]
- else sci ()
- end
- in
- fun fmt spec =
- let
- val doit =
- case spec of
- EXACT => IEEEReal.toString o toDecimal
- | FIX opt =>
- let
- val n =
- case opt of
- NONE => 6
- | SOME n =>
- if Primitive.safe andalso Int.< (n, 0)
- then raise Size
- else n
- in
- fn x =>
- let
- val sign = if x < zero then "~" else ""
- val (cs, decpt) = gdtoa (x, Fix, n)
- in
- fix (sign, cs, decpt, n)
- end
- end
- | GEN opt =>
- let
- val n =
- case opt of
- NONE => 12
- | SOME n =>
- if Primitive.safe andalso Int.< (n, 1)
- then raise Size
- else n
- in
- fn x => gen (x, n)
- end
- | SCI opt =>
- let
- val n =
- case opt of
- NONE => 6
- | SOME n =>
- if Primitive.safe andalso Int.< (n, 0)
- then raise Size
- else n
- in
- fn x => sci (x, n)
- end
- in
- fn x =>
- case class x of
- NAN => "nan"
- | INF => if x > zero then "inf" else "~inf"
- | _ => doit x
- end
- end
-
- val toString = fmt (StringCvt.GEN NONE)
-
- val fromLargeInt: LargeInt.int -> real =
- fn i =>
- fromInt (IntInf.toInt i)
- handle Overflow =>
- let
- val (i, sign) =
- if LargeInt.< (i, 0)
- then (LargeInt.~ i, true)
- else (i, false)
- val x = Prim.strto (NullString.fromString
- (concat [LargeInt.toString i, "\000"]))
- in
- if sign then ~ x else x
- end
-
- val toLargeInt: IEEEReal.rounding_mode -> real -> LargeInt.int =
- fn mode => fn x =>
- case class x of
- INF => raise Overflow
- | NAN => raise Domain
- | ZERO => 0
- | _ =>
- let
- (* This round may turn x into an INF, so we need to check the
- * class again.
- *)
- val x = roundReal (x, mode)
- in
- case class x of
- INF => raise Overflow
- | _ =>
- if minInt <= x andalso x <= maxInt
- then LargeInt.fromInt (Prim.toInt x)
- else
- valOf
- (LargeInt.fromString (fmt (StringCvt.FIX (SOME 0)) x))
- end
-
- structure Math =
- struct
- open Prim.Math
-
- (* Patch functions to handle out-of-range args. Many C math
- * libraries do not do what the SML Basis Spec requires.
- *)
-
- local
- fun patch f x =
- if x < ~one orelse x > one
- then nan
- else f x
- in
- val acos = patch acos
- val asin = patch asin
- end
-
- local
- fun patch f x = if x < zero then nan else f x
- in
- val ln = patch ln
- val log10 = patch log10
- end
-
- (* The x86 doesn't get exp right on infs. *)
- val exp =
- if MLton.Codegen.isNative
- andalso let open MLton.Platform.Arch in host = X86 end
- then (fn x =>
- case class x of
- INF => if x > zero then posInf else zero
- | _ => exp x)
- else exp
-
- (* The Cygwin math library doesn't get pow right on some exceptional
- * cases.
- *
- * The Linux math library doesn't get pow (x, y) right when x < 0
- * and y is large (but finite).
- *
- * So, we define a pow function that gives the correct result on
- * exceptional cases, and only calls the C pow with x > 0.
- *)
- fun isInt (x: real): bool = x == realFloor x
-
- (* isEven x assumes isInt x. *)
- fun isEven (x: real): bool = isInt (x / two)
-
- fun isOddInt x = isInt x andalso not (isEven x)
-
- fun isNeg x = x < zero
-
- fun pow (x, y) =
- case class y of
- INF =>
- if class x = NAN
- then nan
- else if x < negOne orelse x > one
- then if isNeg y then zero else posInf
- else if negOne < x andalso x < one
- then if isNeg y then posInf else zero
- else (* x = 1 orelse x = ~1 *)
- nan
- | NAN => nan
- | ZERO => one
- | _ =>
- (case class x of
- INF =>
- if isNeg x
- then if isNeg y
- then if isOddInt y
- then ~ zero
- else zero
- else if isOddInt y
- then negInf
- else posInf
- else (* x = posInf *)
- if isNeg y then zero else posInf
- | NAN => nan
- | ZERO =>
- if isNeg y
- then if isOddInt y
- then copySign (posInf, x)
- else posInf
- else if isOddInt y
- then x
- else zero
- | _ =>
- if isNeg x
- then if isInt y
- then if isEven y
- then Prim.Math.pow (~ x, y)
- else negOne * Prim.Math.pow (~ x, y)
- else nan
- else Prim.Math.pow (x, y))
-
- fun cosh x =
- case class x of
- INF => x
- | ZERO => one
- | _ => R.Math.cosh x
-
- fun sinh x =
- case class x of
- INF => x
- | ZERO => x
- | _ => R.Math.sinh x
-
- fun tanh x =
- case class x of
- INF => if x > zero then one else negOne
- | ZERO => x
- | _ => R.Math.tanh x
- end
- end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/real/real.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/real/real.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/real/real.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -1,8 +1,3 @@
-structure LargeReal =
- struct
- type real = real
- end
-
signature PRE_REAL_GLOBAL =
sig
type real
@@ -27,24 +22,43 @@
val ?= : real * real -> bool
val ~ : real -> real
val abs: real -> real
- val class: real -> Primitive.Real64.Class.t
- val frexp: real * int ref -> real
- val gdtoa: real * int * int * int ref -> Primitive.CString.t
- val fromInt: int -> real
- val fromLarge: IEEEReal.rounding_mode -> LargeReal.real -> real
- val ldexp: real * int -> real
+
val maxFinite: real
val minNormalPos: real
val minPos: real
+
+ val realSize: Primitive.Int32.int
+ val precision: Primitive.Int32.int
+ val radix: Primitive.Int32.int
+
+ val class: real -> C_Int.t
+ val signBit: real -> C_Int.t
+
+ val nextAfter: real * real -> real
+
+ val frexp: real * C_Int.int ref -> real
+ val ldexp: real * C_Int.int -> real
val modf: real * real ref -> real
- val nextAfterDown: real -> real
- val nextAfterUp: real -> real
- val precision: int
- val radix: int
- val signBit: real -> int
- val strto: NullString.t -> real
- val toInt: real -> int
- val toLarge: real -> LargeReal.real
+
+ val round: real -> real
+ val gdtoa: real * C_Int.t * C_Int.t * C_Int.t ref -> C_String.t
+ val strto: Primitive.NullString8.t -> real
+
+ val fromInt8Unsafe: Primitive.Int8.int -> real
+ val fromInt16Unsafe: Primitive.Int16.int -> real
+ val fromInt32Unsafe: Primitive.Int32.int -> real
+ val fromInt64Unsafe: Primitive.Int64.int -> real
+
+ val fromReal32Unsafe: Primitive.Real32.real -> real
+ val fromReal64Unsafe: Primitive.Real64.real -> real
+
+ val toInt8Unsafe: real -> Primitive.Int8.int
+ val toInt16Unsafe: real -> Primitive.Int16.int
+ val toInt32Unsafe: real -> Primitive.Int32.int
+ val toInt64Unsafe: real -> Primitive.Int64.int
+
+ val toReal32Unsafe: real -> Primitive.Real32.real
+ val toReal64Unsafe: real -> Primitive.Real64.real
end
signature REAL_GLOBAL =
@@ -120,3 +134,9 @@
val toString: real -> string
val unordered: real * real -> bool
end
+
+signature REAL_EXTRA =
+ sig
+ include REAL
+ val realSize: Int.int
+ end
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/real/real.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.sml)
Deleted: mlton/branches/on-20050822-x86_64-branch/basis-library/real/real32.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/real/real32.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/real/real32.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -1,33 +0,0 @@
-(* Copyright (C) 2003-2005 Henry Cejtin, Matthew Fluet, Suresh
- * Jagannathan, and Stephen Weeks.
- *
- * MLton is released under a BSD-style license.
- * See the file MLton-LICENSE for details.
- *)
-
-structure Real32 =
- Real
- (structure P = Primitive.Real32
- open P
- fun fromLarge m r =
- IEEEReal.withRoundingMode (m, fn () => P.fromLarge r)
-
- val realToWord: real -> word =
- fn r =>
- Word.fromLarge (PackWord32Little.subVec (PackReal32Little.toBytes r, 0))
-
- val wordToReal: word -> real =
- let
- val a = Word8Array.array (4, 0w0)
- in
- fn w =>
- let
- val _ = PackWord32Little.update (a, 0, Word.toLarge w)
- in
- PackReal32Little.subArr (a, 0)
- end
- end
-
- fun nextAfterUp r = wordToReal (Word.+ (realToWord r, 0w1))
- fun nextAfterDown r = wordToReal (Word.- (realToWord r, 0w1))
- )
Deleted: mlton/branches/on-20050822-x86_64-branch/basis-library/real/real64.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/real/real64.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/real/real64.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -1,22 +0,0 @@
-(* Copyright (C) 2003-2005 Henry Cejtin, Matthew Fluet, Suresh
- * Jagannathan, and Stephen Weeks.
- *
- * MLton is released under a BSD-style license.
- * See the file MLton-LICENSE for details.
- *)
-
-structure Real64 =
- Real
- (structure P = Primitive.Real64
- open P
- fun fromLarge _ r = P.fromLarge r
- val negInf = ~1.0 / 0.0
- val posInf = 1.0 / 0.0
- fun nextAfterDown r = nextAfter (r, negInf)
- fun nextAfterUp r = nextAfter (r, posInf)
- )
-structure Real = Real64
-val real = Real.fromInt
-structure RealGlobal: REAL_GLOBAL = Real
-open RealGlobal
-structure LargeReal = Real64
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/sml-nj/unsafe.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/sml-nj/unsafe.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/sml-nj/unsafe.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -12,7 +12,7 @@
val sub = unsafeSub
val update = unsafeUpdate
- val create = fromPoly o Primitive.Array.array
+ val create = fromPoly o Array.arrayUninit
end
functor UnsafeMonoVector (V: MONO_VECTOR_EXTRA): UNSAFE_MONO_VECTOR =
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/system/command-line.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/system/command-line.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/system/command-line.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -11,9 +11,9 @@
structure Prim = PrimitiveFFI.CommandLine
fun name () =
- COld.CS.toString (Prim.commandNameGet ())
+ CUtil.C_String.toString (Prim.commandNameGet ())
fun arguments () =
- (Array.toList o COld.CSS.toArrayOfLength)
- (Prim.argvGet (), Prim.argcGet ())
+ (Array.toList o CUtil.C_StringArray.toArrayOfLength)
+ (Prim.argvGet (), C_Int.toInt (Prim.argcGet ()))
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/system/date.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/system/date.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/system/date.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -1,4 +1,5 @@
(* Modified from the ML Kit 4.1.4; basislib/Date.sml
+ * by mfluet@acm.org on 2006-4-25
* by mfluet@acm.org on 2005-8-10 based on
* modifications from the ML Kit Version 3; basislib/Date.sml
* by sweeks@research.nj.nec.com on 1999-1-3 and
@@ -59,18 +60,17 @@
(* 86400 = 24*60*6 is the number of seconds per day *)
- type tmoz = {tm_hour : int,
- tm_isdst : int, (* 0 = no, 1 = yes, ~1 = don't know *)
- tm_mday : int,
- tm_min : int,
- tm_mon : int,
- tm_sec : int,
- tm_wday : int,
- tm_yday : int,
- tm_year : int}
-
+ type tmoz = {tm_hour : C_Int.t,
+ tm_isdst : C_Int.t, (* 0 = no, 1 = yes, ~1 = don't know *)
+ tm_mday : C_Int.t,
+ tm_min : C_Int.t,
+ tm_mon : C_Int.t,
+ tm_sec : C_Int.t,
+ tm_wday : C_Int.t,
+ tm_yday : C_Int.t,
+ tm_year : C_Int.t}
local
- fun make (f: int ref -> int) (n: int): tmoz =
+ fun make (f: C_Time.t ref -> C_Int.t C_Errno.t) (n: C_Time.t) : tmoz =
(ignore (f (ref n))
; {tm_hour = Tm.getHour (),
tm_isdst = Tm.getIsDst (),
@@ -86,8 +86,8 @@
val getgmtime_ = make Prim.gmTime
end
- fun setTmBuf {tm_hour, tm_isdst, tm_mday, tm_min, tm_mon, tm_sec, tm_wday,
- tm_yday, tm_year} =
+ fun setTmBuf ({tm_hour, tm_isdst, tm_mday, tm_min, tm_mon,
+ tm_sec, tm_wday, tm_yday, tm_year}: tmoz) : unit =
(Tm.setHour tm_hour
; Tm.setIsDst tm_isdst
; Tm.setMDay tm_mday
@@ -98,10 +98,10 @@
; Tm.setYDay tm_yday
; Tm.setYear tm_year)
- fun mktime_ (t: tmoz): int = (setTmBuf t; Prim.mkTime ())
+ fun mktime_ (t: tmoz): C_Time.t = C_Errno.check (setTmBuf t; Prim.mkTime ())
(* The offset to add to local time to get UTC: positive West of UTC *)
- val localoffset: int = Real.round (Prim.localOffset ())
+ val localoffset: int = C_Double.round (Prim.localOffset ())
val toweekday: int -> weekday =
fn 0 => Sun | 1 => Mon | 2 => Tue | 3 => Wed
@@ -123,21 +123,21 @@
| May => 4 | Jun => 5 | Jul => 6 | Aug => 7
| Sep => 8 | Oct => 9 | Nov => 10 | Dec => 11
- fun tmozToDate ({tm_hour, tm_isdst, tm_mday, tm_min, tm_mon, tm_sec,
- tm_wday, tm_yday, tm_year}: tmoz) offset =
- T {day = tm_mday,
- hour = tm_hour,
+ fun tmozToDate ({tm_hour, tm_isdst, tm_mday, tm_min, tm_mon,
+ tm_sec, tm_wday, tm_yday, tm_year}: tmoz) offset =
+ T {day = C_Int.toInt tm_mday,
+ hour = C_Int.toInt tm_hour,
isDst = (case tm_isdst of
0 => SOME false
| 1 => SOME true
| _ => NONE),
- minute = tm_min,
- month = tomonth tm_mon,
+ minute = C_Int.toInt tm_min,
+ month = tomonth (C_Int.toInt tm_mon),
offset = offset,
- second = tm_sec,
- weekDay = toweekday tm_wday,
- year = tm_year + 1900,
- yearDay = tm_yday}
+ second = C_Int.toInt tm_sec,
+ weekDay = toweekday (C_Int.toInt tm_wday),
+ yearDay = C_Int.toInt tm_yday,
+ year = (C_Int.toInt tm_year) + 1900}
fun leapyear (y: int) =
y mod 4 = 0 andalso y mod 100 <> 0 orelse y mod 400 = 0
@@ -170,18 +170,18 @@
weekDay, yearDay, isDst, ...}): tmoz =
if not (okDate dt)
then raise Date
- else {tm_hour = hour,
- tm_mday = day,
- tm_min = minute,
- tm_mon = frommonth month,
- tm_sec = second,
- tm_year = year -? 1900,
+ else {tm_hour = C_Int.fromInt hour,
tm_isdst = (case isDst of
SOME false => 0
| SOME true => 1
| NONE=> ~1),
- tm_wday = fromwday weekDay,
- tm_yday = yearDay}
+ tm_mday = C_Int.fromInt day,
+ tm_min = C_Int.fromInt minute,
+ tm_mon = C_Int.fromInt (frommonth month),
+ tm_sec = C_Int.fromInt second,
+ tm_wday = C_Int.fromInt (fromwday weekDay),
+ tm_yday = C_Int.fromInt yearDay,
+ tm_year = C_Int.fromInt (year - 1900)}
(* -------------------------------------------------- *)
(* Translated from Emacs's calendar.el: *)
@@ -279,10 +279,10 @@
end
fun fromTimeLocal t =
- tmozToDate (getlocaltime_ (Time.toSeconds t)) NONE
+ tmozToDate (getlocaltime_ (C_Time.fromInt (Time.toSeconds t))) NONE
fun fromTimeUniv t =
- tmozToDate (getgmtime_ (Time.toSeconds t)) (SOME 0)
+ tmozToDate (getgmtime_ (C_Time.fromInt (Time.toSeconds t))) (SOME 0)
(* The following implements conversion from a local date to
* a Time.time. It IGNORES wday and yday.
@@ -294,7 +294,7 @@
case offset of
NONE => 0
| SOME secs => localoffset + secs
- val clock = mktime_ (dateToTmoz date) - secoffset
+ val clock = C_Time.toInt (mktime_ (dateToTmoz date)) - secoffset
in
if clock < 0 then raise Date
else Time.fromSeconds clock
@@ -307,7 +307,7 @@
let
val a = Array.tabulate (Char.maxOrd + 1, fn _ => false)
val validChars = "aAbBcdHIjmMpSUwWxXyYZ%"
- in Util.naturalForeach
+ in Natural.foreach
(size validChars, fn i =>
Array.update (a, Char.ord (String.sub (validChars, i)), true));
fn c => Array.sub (a, Char.ord c)
@@ -317,14 +317,14 @@
let
val _ = setTmBuf (dateToTmoz d)
val bufLen = 50 (* more than enough for a single format char *)
- val buf = Primitive.Array.array bufLen
+ val buf = Array.arrayUninit bufLen
fun strftime fmtChar =
let
val len =
Prim.strfTime
- (buf, Word.fromInt bufLen,
+ (buf, C_Size.fromInt bufLen,
NullString.fromString (concat ["%", str fmtChar, "\000"]))
- val len = Word.toInt len
+ val len = C_Size.toInt len
in if len = 0
then raise Fail "Date.fmt"
else ArraySlice.vector (ArraySlice.slice (buf, 0, SOME len))
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/system/file-sys.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/system/file-sys.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/system/file-sys.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -34,7 +34,7 @@
val readLink = P_FSys.readlink
(* the maximum number of links allowed *)
- val maxLinks = 64
+ val maxLinks: int = 64
structure P = OS_Path
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/system/io.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/system/io.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/system/io.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -1,6 +1,7 @@
(* 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 *)
+(* modified by Matthew Fluet 2006-04-30 *)
(* os-io.sml
*
@@ -22,25 +23,18 @@
datatype iodesc_kind = K of string
- type file_desc = Primitive.FileDesc.t
+ type file_desc = Posix.FileSys.file_desc
- fun toFD (iod: iodesc): file_desc =
- valOf (Posix.FileSys.iodToFD iod)
+ val iodToFd = fn x => x
+ val fdToIod = fn x => x
- val FD = Primitive.FileDesc.fromInt
- val unFD = Primitive.FileDesc.toInt
+ val iodescToWord = C_Fd.toSysWord
- fun fromInt i = Posix.FileSys.fdToIOD (FD i)
-
- val toInt: iodesc -> int = unFD o toFD
-
- val toWord = Posix.FileSys.fdToWord o toFD
-
(* return a hash value for the I/O descriptor. *)
- val hash = toWord
+ val hash = SysWord.toWord o iodescToWord
(* compare two I/O descriptors *)
- fun compare (i, i') = Word.compare (toWord i, toWord i')
+ fun compare (i, i') = SysWord.compare (iodescToWord i, iodescToWord i')
structure Kind =
struct
@@ -55,7 +49,7 @@
(* return the kind of I/O descriptor *)
fun kind (iod) = let
- val stat = Posix.FileSys.fstat (toFD iod)
+ val stat = Posix.FileSys.fstat (iodToFd iod)
in
if (Posix.FileSys.ST.isReg stat) then Kind.file
else if (Posix.FileSys.ST.isDir stat) then Kind.dir
@@ -96,26 +90,23 @@
local
structure Prim = PrimitiveFFI.OS.IO
fun join (false, _, w) = w
- | join (true, b, w) = Word16.orb(w, b)
- fun test (w, b) = (Word16.andb(w, b) <> 0w0)
- val rdBit : Word16.word = Primitive.Word16.fromInt16 PrimitiveFFI.OS.IO.POLLIN
- and wrBit : Word16.word = Primitive.Word16.fromInt16 PrimitiveFFI.OS.IO.POLLOUT
- and priBit : Word16.word = Primitive.Word16.fromInt16 PrimitiveFFI.OS.IO.POLLPRI
+ | join (true, b, w) = C_Short.orb(w, b)
+ fun test (w, b) = (C_Short.andb(w, b) <> 0)
+ val rdBit = PrimitiveFFI.OS.IO.POLLIN
+ and wrBit = PrimitiveFFI.OS.IO.POLLOUT
+ and priBit = PrimitiveFFI.OS.IO.POLLPRI
fun fromPollDesc (PollDesc (iod, {rd, wr, pri})) =
- ( toInt iod,
- Primitive.Word16.toInt16 (
+ ( iodToFd iod,
join (rd, rdBit,
join (wr, wrBit,
- join (pri, priBit, 0w0))))
+ join (pri, priBit, 0)))
)
fun toPollInfo (fd, i) =
- let val w = Primitive.Word16.fromInt16 i
- in PollInfo (fromInt fd, {
- rd = test(w, rdBit),
- wr = test(w, wrBit),
- pri = test(w, priBit)
+ PollInfo (fdToIod fd, {
+ rd = test(i, rdBit),
+ wr = test(i, wrBit),
+ pri = test(i, priBit)
})
- end
in
fun poll (pds, timeOut) = let
val (fds, eventss) = ListPair.unzip (List.map fromPollDesc pds)
@@ -128,7 +119,7 @@
| SOME t =>
if Time.< (t, Time.zeroTime)
then let open PosixError in raiseSys inval end
- else (Int.fromLarge (Time.toMilliseconds t)
+ else (C_Int.fromLarge (Time.toMilliseconds t)
handle Overflow => Error.raiseSys Error.inval)
val reventss = Array.array (n, 0)
val _ = Posix.Error.SysCall.simpleRestart
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/system/pre-os.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/system/pre-os.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/system/pre-os.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -11,18 +11,10 @@
struct
type status = C_Status.t
end
- structure IO :> sig
- eqtype iodesc
-
- val fromFD: C_Fd.t -> iodesc
- val toFD: iodesc -> C_Fd.t
- end =
- struct
- type iodesc = C_Fd.t
-
- val fromFD = fn z => z
- val toFD = fn z => z
- end
+ structure IO =
+ struct
+ type iodesc = C_Fd.t
+ end
end
structure PreOS = OS
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/system/process.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/system/process.sig 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/system/process.sig 2006-05-06 18:44:35 UTC (rev 4468)
@@ -19,7 +19,7 @@
structure Status:
sig
- type t
+ type t = status
val fromInt: int -> t
val fromPosix: Posix.Process.exit_status -> t
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/system/process.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/system/process.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/system/process.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -17,8 +17,14 @@
structure Status =
struct
- open Primitive.Status
+ type t = C_Status.t
+ val fromInt = C_Status.fromInt
+ val toInt = C_Status.toInt
+
+ val failure = fromInt 1
+ val success = fromInt 0
+
val fromPosix =
fn es =>
let
@@ -26,7 +32,7 @@
in
case es of
W_EXITED => success
- | W_EXITSTATUS w => fromInt (Word8.toInt w)
+ | W_EXITSTATUS w => C_Status.fromSysWord (Word8.toSysWord w)
| W_SIGNALED _ => failure
| W_STOPPED _ => failure
end
@@ -39,8 +45,9 @@
fun isSuccess st = st = success
fun system cmd =
- PrimitiveFFI.Posix.Process.system (NullString.fromString
- (concat [cmd, "\000"]))
+ Posix.Error.SysCall.simpleResult
+ (fn () =>
+ PrimitiveFFI.Posix.Process.system (NullString.nullTerm cmd))
val atExit = MLtonProcess.atExit
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/system/time.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/system/time.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/system/time.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -23,12 +23,13 @@
val zeroTime = T 0
fun fromReal r =
- T (Real.toLargeInt IEEEReal.TO_NEAREST
- (Real.* (r, Real.fromLargeInt ticksPerSecond)))
+ T (LargeReal.toLargeInt IEEEReal.TO_NEAREST
+ (LargeReal.* (r, LargeReal.fromLargeInt ticksPerSecond)))
handle Overflow => raise Time
fun toReal (T i) =
- Real./ (Real.fromLargeInt i, Real.fromLargeInt ticksPerSecond)
+ LargeReal./ (LargeReal.fromLargeInt i,
+ LargeReal.fromLargeInt ticksPerSecond)
local
fun make ticksPer =
@@ -87,7 +88,7 @@
end
val fmt: int -> time -> string =
- fn n => (Real.fmt (StringCvt.FIX (SOME n))) o toReal
+ fn n => (LargeReal.fmt (StringCvt.FIX (SOME n))) o toReal
val toString = fmt 3
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/text/byte.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/text/byte.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/text/byte.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -8,25 +8,24 @@
structure Byte: BYTE =
struct
- val byteToChar = Primitive.Char.fromWord8
+ val byteToChar = Primitive.Char8.fromWord8Unsafe
- val bytesToString = Primitive.String.fromWord8Vector o Word8Vector.toPoly
+ val bytesToString = Primitive.String8.fromWord8Vector o Word8Vector.toPoly
- val charToByte = Primitive.Char.toWord8
+ val charToByte = Primitive.Char8.toWord8Unsafe
fun packString (a: Word8Array.array, i: int, s: substring): unit =
- Util.naturalForeach
+ Natural.foreach
(Substring.size s, fn j =>
- Word8Array.update (a, i +? j, charToByte (Substring.sub (s, j))))
+ Word8Array.update (a, i + j, charToByte (Substring.sub (s, j))))
- val stringToBytes = Word8Vector.fromPoly o Primitive.String.toWord8Vector
+ val stringToBytes = Word8Vector.fromPoly o Primitive.String8.toWord8Vector
local
fun make (length, sub) s =
String.tabulate (length s, fn i => byteToChar (sub (s, i)))
in
val unpackString = make (Word8ArraySlice.length, Word8ArraySlice.sub)
- val unpackStringVec =
- make (Word8VectorSlice.length, Word8VectorSlice.sub)
+ val unpackStringVec = make (Word8VectorSlice.length, Word8VectorSlice.sub)
end
end
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/text/char-global.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/char-global.sml)
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/text/char.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/text/char.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/text/char.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -8,14 +8,14 @@
structure Char: CHAR_EXTRA =
struct
- open Char0
+ open PreChar
fun control reader state =
case reader state of
NONE => NONE
| SOME (c, state) =>
if #"@" <= c andalso c <= #"_"
- then SOME (chr (ord c -? ord #"@"), state)
+ then SOME (chr (Int.-? (ord c, ord #"@")), state)
else NONE
fun formatChar reader state =
@@ -159,10 +159,10 @@
fun padLeft (s: string, n: int): string =
let
- val m = String.size s
- val diff = n -? m
+ val m = PreString.size s
+ val diff = Int.-? (n, m)
in if Int.> (diff, 0)
- then String.concat [String.new (diff, #"0"), s]
+ then PreString.concat [PreString.new (diff, #"0"), s]
else if diff = 0
then s
else raise Fail "padLeft"
@@ -176,7 +176,7 @@
(case c of
#"\\" => "\\\\"
| #"\"" => "\\\""
- | _ => String0.str c)
+ | _ => PreString.str c)
else
case c of
#"\a" => "\\a"
@@ -188,9 +188,9 @@
| #"\r" => "\\r"
| _ =>
if c < #" "
- then (String.concat
- ["\\^", String0.str (chr (ord c +? ord #"@"))])
- else String.concat
+ then (PreString.concat
+ ["\\^", PreString.str (chr (Int.+? (ord c, ord #"@")))])
+ else PreString.concat
["\\", padLeft (Int.fmt StringCvt.DEC (ord c), 3)])
val toCString =
@@ -203,7 +203,7 @@
| #"\"" => "\\\""
| #"?" => "\\?"
| #"'" => "\\'"
- | _ => String0.str c)
+ | _ => PreString.str c)
else
case c of
#"\a" => "\\a"
@@ -214,10 +214,6 @@
| #"\f" => "\\f"
| #"\r" => "\\r"
| _ =>
- String.concat
+ PreString.concat
["\\", padLeft (Int.fmt StringCvt.OCT (ord c), 3)])
end
-
-structure CharGlobal: CHAR_GLOBAL = Char
-open CharGlobal
-
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/text/char0.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/text/char0.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/text/char0.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -6,50 +6,62 @@
* See the file MLton-LICENSE for details.
*)
-structure Char0 =
+structure PreChar8 =
struct
- open Primitive.Int Primitive.Char
+ structure Prim = Primitive.Char8
+ open Primitive.Char8
- type char = char
- type string = string
+ type char = Primitive.Char8.char
+ type string = Primitive.String8.string
- val minChar = #"\000"
+ local
+ structure S =
+ Int_ChooseInt
+ (type 'a t = 'a -> char
+ val fInt8 = Prim.fromInt8Unsafe
+ val fInt16 = Prim.fromInt16Unsafe
+ val fInt32 = Prim.fromInt32Unsafe
+ val fInt64 = Prim.fromInt64Unsafe
+ val fIntInf = Prim.fromIntInfUnsafe)
+ in
+ val chrUnsafe = S.f
+ end
+ val ord = Primitive.Word8.toInt o Prim.toWord8Unsafe
+
+ val minChar: char = #"\000"
val numChars: int = 256
val maxOrd: int = 255
- val maxChar = #"\255"
+ val maxChar:char = #"\255"
fun succ c =
- if Primitive.safe andalso c = maxChar
+ if Primitive.Controls.safe andalso c = maxChar
then raise Chr
- else Primitive.Char.chr (ord c + 1)
+ else chrUnsafe (Int.+ (ord c, 1))
fun pred c =
- if Primitive.safe andalso c = minChar
+ if Primitive.Controls.safe andalso c = minChar
then raise Chr
- else Primitive.Char.chr (ord c - 1)
+ else chrUnsafe (Int.- (ord c, 1))
fun chrOpt c =
- if Primitive.safe andalso Primitive.Int.gtu (c, maxOrd)
+ if Primitive.Controls.safe
+ andalso Int.gtu (c, maxOrd)
then NONE
- else SOME (Primitive.Char.chr c)
+ else SOME (chrUnsafe c)
fun chr c =
case chrOpt c of
NONE => raise Chr
| SOME c => c
- val {compare, ...} = Util.makeCompare (op <)
-
- structure String = String0
-
fun oneOf s =
let
val a = Array.array (numChars, false)
- val n = String.size s
+ val n = PreString8.size s
fun loop i =
- if Primitive.Int.>= (i, n) then ()
- else (Array.update (a, ord (String.sub (s, i)), true)
- ; loop (i + 1))
+ if Int.>= (i, n) then ()
+ else (Array.update (a, ord (PreString8.sub (s, i)), true)
+ ; loop (Int.+ (i, 1)))
in loop 0
; fn c => Array.sub (a, ord c)
end
@@ -65,20 +77,20 @@
local
val not = fn f => memoize (not o f)
- infix or andd
- fun f or g = memoize (fn c => f c orelse g c)
- fun f andd g = memoize (fn c => f c andalso g c)
+ infix || &&
+ fun f || g = memoize (fn c => f c orelse g c)
+ fun f && g = memoize (fn c => f c andalso g c)
in
val isLower = oneOf "abcdefghijklmnopqrstuvwxyz"
val isUpper = oneOf "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
val isDigit = oneOf "0123456789"
- val isAlpha = isUpper or isLower
- val isHexDigit = isDigit or (oneOf "abcdefABCDEF")
- val isAlphaNum = isAlpha or isDigit
+ val isAlpha = isUpper || isLower
+ val isHexDigit = isDigit || (oneOf "abcdefABCDEF")
+ val isAlphaNum = isAlpha || isDigit
val isPrint = fn c => #" " <= c andalso c <= #"~"
val isSpace = oneOf " \t\r\n\v\f"
- val isGraph = (not isSpace) andd isPrint
- val isPunct = isGraph andd (not isAlphaNum)
+ val isGraph = (not isSpace) && isPrint
+ val isPunct = isGraph && (not isAlphaNum)
val isCntrl = not isPrint
val isAscii = fn c => c < #"\128"
end
@@ -86,12 +98,12 @@
local
fun make (lower, upper, diff) =
memoize (fn c => if lower <= c andalso c <= upper
- then chr (ord c +? diff)
+ then chr (Int.+? (ord c, diff))
else c)
- val diff = ord #"A" - ord #"a"
+ val diff = Int.- (ord #"A", ord #"a")
in
- val toLower = make (#"A", #"Z", ~diff)
+ val toLower = make (#"A", #"Z", Int.~ diff)
val toUpper = make (#"a", #"z", diff)
end
end
-
+structure PreChar = PreChar8
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/text/nullstring.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/nullstring.sml)
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/text/string-cvt.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/text/string-cvt.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/text/string-cvt.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -10,7 +10,7 @@
struct
open Reader
- val wordFromInt = Primitive.Word32.fromInt
+ val wordFromInt = Word.fromInt
datatype radix = BIN | OCT | DEC | HEX
@@ -29,27 +29,24 @@
type ('a, 'b) reader = 'b -> ('a * 'b) option
- open Primitive.Int
+ open Int
- structure Char = Char0
- structure String = String0
-
local
fun pad f (c: char) i s =
let
- val n = String.size s
+ val n = PreString.size s
in
if n >= i
then s
- else f (s, String0.vector (i -? n, c))
+ else f (s, PreString.vector (i -? n, c))
end
in
- val padLeft = pad (fn (s, pad) => String.^ (pad, s))
- val padRight = pad String.^
+ val padLeft = pad (fn (s, pad) => PreString.^ (pad, s))
+ val padRight = pad PreString.^
end
fun splitl p f src =
- let fun done chars = String0.implode (rev chars)
+ let fun done chars = PreString.implode (rev chars)
fun loop (src, chars) =
case f src of
NONE => (done chars, src)
@@ -63,14 +60,14 @@
fun takel p f s = #1 (splitl p f s)
fun dropl p f s = #2 (splitl p f s)
- fun skipWS x = dropl Char.isSpace x
+ fun skipWS x = dropl PreChar.isSpace x
type cs = int
fun stringReader (s: string): (char, cs) reader =
- fn i => if i >= String.size s
+ fn i => if i >= PreString.size s
then NONE
- else SOME (String.sub (s, i), i + 1)
+ else SOME (PreString.sub (s, i), i + 1)
fun 'a scanString (f: ((char, cs) reader -> ('a, cs) reader)) (s: string)
: 'a option =
@@ -80,14 +77,14 @@
local
fun range (add: int, cmin: char, cmax: char): char -> int option =
- let val min = Char.ord cmin
- in fn c => if Char.<= (cmin, c) andalso Char.<= (c, cmax)
- then SOME (add +? Char.ord c -? min)
+ let val min = PreChar.ord cmin
+ in fn c => if PreChar.<= (cmin, c) andalso PreChar.<= (c, cmax)
+ then SOME (add +? PreChar.ord c -? min)
else NONE
end
fun 'a combine (ds: (char -> 'a option) list): char -> 'a option =
- Char.memoize
+ PreChar.memoize
(fn c =>
let
val rec loop =
@@ -99,9 +96,9 @@
in loop ds
end)
- val bin = Char.memoize (range (0, #"0", #"1"))
- val oct = Char.memoize (range (0, #"0", #"7"))
- val dec = Char.memoize (range (0, #"0", #"9"))
+ val bin = PreChar.memoize (range (0, #"0", #"1"))
+ val oct = PreChar.memoize (range (0, #"0", #"7"))
+ val dec = PreChar.memoize (range (0, #"0", #"9"))
val hex = combine [range (0, #"0", #"9"),
range (10, #"a", #"f"),
range (10, #"A", #"F")]
@@ -177,8 +174,8 @@
fun wdigits radix reader state =
let
- val op + = Primitive.Word32.+
- val op * = Primitive.Word32.*
+ val op + = Word.+
+ val op * = Word.*
val r = radixToWord radix
fun loop (accum, state) =
case reader state of
@@ -195,5 +192,5 @@
| SOME n => loop (n, state)
end
- fun digitToChar (n: int): char = String.sub ("0123456789ABCDEF", n)
+ fun digitToChar (n: int): char = PreString.sub ("0123456789ABCDEF", n)
end
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/text/string-global.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/string-global.sml)
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/text/string.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/text/string.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/text/string.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -8,7 +8,7 @@
structure String: STRING_EXTRA =
struct
- open String0
+ open PreString
val toLower = translate (str o Char.toLower)
@@ -20,7 +20,12 @@
val isSuffix = make isSuffix
end
val compare = collate Char.compare
- val {<, <=, >, >=} = Util.makeOrder compare
+ local
+ structure S = StringComparisons (type t = string
+ val compare = compare)
+ in
+ open S
+ end
val toString = translate Char.toString
val toCString = translate Char.toCString
@@ -49,21 +54,3 @@
fun nullTerm s = s ^ "\000"
end
-
-structure StringGlobal: STRING_GLOBAL = String
-open StringGlobal
-
-(* Now that concat is defined, we can add the exnMessager for Fail. *)
-val _ =
- General.addExnMessager
- (fn e =>
- case e of
- Fail s => SOME (concat ["Fail: ", s])
- | _ => NONE)
-
-structure NullString =
- struct
- open NullString
-
- val nullTerm = fromString o String.nullTerm
- end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/text/string0.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/text/string0.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/text/string0.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -6,12 +6,12 @@
* See the file MLton-LICENSE for details.
*)
-structure String0 =
+structure PreString8 =
struct
open CharVector
type char = elem
type string = vector
- structure Substring0 =
+ structure PreSubstring =
struct
open CharVectorSlice
type char = elem
@@ -29,4 +29,4 @@
val implode = fromList
val explode = toList
end
-structure Substring0 = String0.Substring0
+structure PreString = PreString8
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/text/substring-global.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/text/substring-global.sml)
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/text/substring.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/text/substring.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/text/substring.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -9,14 +9,12 @@
(* The :> is to hide the type substring. We must add the where's to make char
* and string the same as the toplevel types.
*)
-structure Substring
- :> SUBSTRING_EXTRA
- where type char = char
- where type string = string
- where type substring = CharVectorSlice.slice
- =
+structure Substring :> SUBSTRING_EXTRA
+ where type char = char
+ where type string = string
+ where type substring = CharVectorSlice.slice =
struct
- open Substring0
+ open PreString.PreSubstring
val size = length
val extract = slice
@@ -35,6 +33,7 @@
val position = make position
end
val compare = collate Char.compare
+
(*
type cs = int
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/top-level/infixes-unsafe.sml (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/top-level/infixes-unsafe.sml)
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/util (from rev 4467, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util)
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/control/control-flags.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/control/control-flags.sml 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/control/control-flags.sml 2006-05-06 18:44:35 UTC (rev 4468)
@@ -82,16 +82,16 @@
toString = Bool.toString}
val defaultChar = control {name = "defaultChar",
- default = "default-char8.sml",
+ default = "char8",
toString = fn s => s}
val defaultInt = control {name = "defaultInt",
- default = "default-int32.sml",
+ default = "int32",
toString = fn s => s}
val defaultReal = control {name = "defaultReal",
- default = "default-real64.sml",
+ default = "real64",
toString = fn s => s}
val defaultWord = control {name = "defaultWord",
- default = "default-word32.sml",
+ default = "word32",
toString = fn s => s}
val diagPasses =
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/front-end/mlb-front-end.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/front-end/mlb-front-end.fun 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/front-end/mlb-front-end.fun 2006-05-06 18:44:35 UTC (rev 4468)
@@ -115,13 +115,13 @@
{var = "SEQINDEX_INT",
path = "seqindex-int32.sml"},
{var = "DEFAULT_CHAR",
- path = !Control.defaultChar},
+ path = concat ["default-", !Control.defaultChar, ".sml"]},
{var = "DEFAULT_INT",
- path = !Control.defaultInt},
+ path = concat ["default-", !Control.defaultInt, ".sml"]},
{var = "DEFAULT_REAL",
- path = !Control.defaultReal},
+ path = concat ["default-", !Control.defaultReal, ".sml"]},
{var = "DEFAULT_WORD",
- path = !Control.defaultWord}],
+ path = concat ["default-", !Control.defaultWord, ".sml"]}],
List.concat (List.map (!Control.mlbPathMaps, make))])
fun peekPathMap var' =
Modified: mlton/branches/on-20050822-x86_64-branch/mlton/main/main.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/main/main.fun 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/main/main.fun 2006-05-06 18:44:35 UTC (rev 4468)
@@ -197,18 +197,18 @@
(Normal, "default-type", " '<ty><N>'", "set default type",
SpaceString
(fn s => (case s of
- "char8" => Control.defaultChar := "default-char8.sml"
- | "int8" => Control.defaultInt := "default-int8.sml"
- | "int16" => Control.defaultInt := "default-int16.sml"
- | "int32" => Control.defaultInt := "default-int32.sml"
- | "int64" => Control.defaultInt := "default-int64.sml"
- | "intinf" => Control.defaultInt := "default-intinf.sml"
- | "real32" => Control.defaultReal := "default-real32.sml"
- | "real64" => Control.defaultReal := "default-real64.sml"
- | "word8" => Control.defaultWord := "default-word8.sml"
- | "word16" => Control.defaultWord := "default-word16.sml"
- | "word32" => Control.defaultWord := "default-word32.sml"
- | "word64" => Control.defaultWord := "default-word64.sml"
+ "char8" => Control.defaultChar := s
+ | "int8" => Control.defaultInt := s
+ | "int16" => Control.defaultInt := s
+ | "int32" => Control.defaultInt := s
+ | "int64" => Control.defaultInt := s
+ | "intinf" => Control.defaultInt := s
+ | "real32" => Control.defaultReal := s
+ | "real64" => Control.defaultReal := s
+ | "word8" => Control.defaultWord := s
+ | "word16" => Control.defaultWord := s
+ | "word32" => Control.defaultWord := s
+ | "word64" => Control.defaultWord := s
| _ => usage (concat ["invalid -default-type flag: ", s])))),
(Expert, "diag-pass", " <pass>", "keep diagnostic info for pass",
SpaceString
Modified: mlton/branches/on-20050822-x86_64-branch/runtime/Makefile
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/Makefile 2006-05-06 18:13:28 UTC (rev 4467)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/Makefile 2006-05-06 18:44:35 UTC (rev 4468)
@@ -212,7 +212,7 @@
$(CC) $(OPTCFLAGS) $(WARNCFLAGS) -o gen/gen-types gen/gen-types.c $(UTILOFILES)
cd gen && ./gen-types
cp gen/c-types.h c-types.h
- cp gen/c-types.sml ../basis-library.refactor/config/c/$(TARGET_ARCH)-$(TARGET_OS)/c-types.sml
+ cp gen/c-types.sml ../basis-library/config/c/$(TARGET_ARCH)-$(TARGET_OS)/c-types.sml
cp gen/ml-types.h ml-types.h
rm -f gen/gen-types gen/c-types.h gen/c-types.sml gen/ml-types.h
@@ -221,7 +221,7 @@
cd gen && mlton gen-basis-ffi.sml
cd gen && ./gen-basis-ffi
cp gen/basis-ffi.h basis-ffi.h
- cp gen/basis-ffi.sml ../basis-library.refactor/primitive/basis-ffi.sml
+ cp gen/basis-ffi.sml ../basis-library/primitive/basis-ffi.sml
rm -f gen/gen-basis-ffi gen/basis-ffi.h gen/basis-ffi.sml
gc-gdb.o: gc.c $(GCCFILES) $(HFILES)