[MLton] cvs commit: added flag -sequence-unit {false|true}
Stephen Weeks
sweeks@mlton.org
Fri, 13 Feb 2004 09:05:57 -0800
sweeks 04/02/13 09:05:57
Modified: . Makefile
basis-library/arrays-and-vectors array2.sml sequence.fun
basis-library/general option.sml
basis-library/io stream-io.fun
basis-library/net socket.sml
basis-library/posix error.sml io.sml primitive.sml
process.sml signal.sml tty.sml
basis-library/real pack-real.sml
basis-library/system process.sml time.sml
doc changelog
doc/user-guide man-page.tex
lib/mlton/basic hash-set.sml
man mlton.1
mlton/control control.sig control.sml
mlton/elaborate elaborate-core.fun elaborate-env.fun
type-env.fun type-env.sig
mlton/main main.fun
Log:
MAIL added flag -sequence-unit {false|true}
If true, then in the sequence expression (e1; e2), it is a type
error if e1 is not of type unit.
I implemented it as an error rather than a warning, because it is
easily implemented by unifying the type of e1 with unit, which may
cause a type error. To implement as a warning would require not
unifying, and delaying the check of e1's type until undetermined types
are reported, which seems to me like it could be more confusing that
immediately reporting the error. For example, consider what should be
the inferred type of f in
val f =
let
in
fn g => (g (); ())
end
Forcing g to return type unit means that the type of f is "(unit ->
unit) -> unit". If we didn't force g to return unit, then we wouldn't
know whether to issue a warning or not until we discover the type of
f.
Compiling the basis library with -sequence-unit true turned up a few
spurious errors, and even caught several bugs in cases where return
values from system calls were being ignored.
I also fixed the one spurious error in the MLton library.
There are a couple hundred such errors in the MLton sources proper.
I'll look into those at some point.
Revision Changes Path
1.108 +1 -1 mlton/Makefile
Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/Makefile,v
retrieving revision 1.107
retrieving revision 1.108
diff -u -r1.107 -r1.108
--- Makefile 14 Jan 2004 22:04:25 -0000 1.107
+++ Makefile 13 Feb 2004 17:05:54 -0000 1.108
@@ -206,7 +206,7 @@
world:
$(MAKE) world-no-check
@echo 'Type checking basis.'
- $(MLTON) -dead-code false -stop tc >/dev/null
+ $(MLTON) -dead-code false -sequence-unit true -stop tc >/dev/null
.PHONY: world-no-check
world-no-check:
1.3 +41 -30 mlton/basis-library/arrays-and-vectors/array2.sml
Index: array2.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/arrays-and-vectors/array2.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- array2.sml 10 Apr 2002 07:02:15 -0000 1.2
+++ array2.sml 13 Feb 2004 17:05:54 -0000 1.3
@@ -75,23 +75,25 @@
let
val cols = length row1
val a as {array, ...} = arrayUninit (length rows, cols)
- in List.foldl
- (fn (row: 'a list, i) =>
- let
- 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)))
- i row
- in if i' = max
- then i'
- else raise Size
- end)
- 0 rows
- ; a
+ val _ =
+ List.foldl
+ (fn (row: 'a list, i) =>
+ let
+ 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)))
+ i row
+ in if i' = max
+ then i'
+ else raise Size
+ end)
+ 0 rows
+ in
+ a
end
fun row ({rows, cols, array}, r) =
@@ -171,23 +173,32 @@
(* The list holds the elements in row major order,
* but reversed.
*)
- (List.foldl (fn (x, i) => (Primitive.Array.update (a, i, x)
- ; i -? 1))
- (size -? 1) l
- ; ())
+ let
+ val _ =
+ List.foldl (fn (x, i) =>
+ (Primitive.Array.update (a, i, x)
+ ; i -? 1))
+ (size -? 1) l
+ in
+ ()
+ end
| ColMajor =>
(* The list holds the elements in column major order,
* but reversed.
*)
- (List.foldl (fn (x, (spot, r)) =>
- (Primitive.Array.update (a, spot, x)
- ; if r = 0
- then (spot -? 1 +? size -? cols,
- rows -? 1)
- else (spot -? cols, r -? 1)))
- (size -? 1, rows -? 1)
- l
- ; ())
+ let
+ val _ =
+ List.foldl (fn (x, (spot, r)) =>
+ (Primitive.Array.update (a, spot, x)
+ ; if r = 0
+ then (spot -? 1 +? size -? cols,
+ rows -? 1)
+ else (spot -? cols, r -? 1)))
+ (size -? 1, rows -? 1)
+ l
+ in
+ ()
+ end
; {rows = rows, cols = cols, array = a}
end
else
1.16 +5 -2 mlton/basis-library/arrays-and-vectors/sequence.fun
Index: sequence.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/arrays-and-vectors/sequence.fun,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- sequence.fun 3 Feb 2004 06:56:08 -0000 1.15
+++ sequence.fun 13 Feb 2004 17:05:54 -0000 1.16
@@ -84,8 +84,11 @@
fun new (n, x) = tabulate (n, fn _ => x)
fun fromList l =
- let val a = array (List.length l)
- in List.foldl (fn (c, i) => (Array.update (a, i, c) ; i +? 1)) 0 l ;
+ let
+ val a = array (List.length l)
+ val _ =
+ List.foldl (fn (c, i) => (Array.update (a, i, c) ; i +? 1)) 0 l
+ in
fromArray a
end
1.6 +1 -1 mlton/basis-library/general/option.sml
Index: option.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/general/option.sml,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- option.sml 23 Jun 2003 00:55:33 -0000 1.5
+++ option.sml 13 Feb 2004 17:05:54 -0000 1.6
@@ -15,7 +15,7 @@
fn NONE => NONE
| SOME a => SOME (f a)
-fun app f z = (map f z; ())
+fun app f z = (ignore (map f z); ())
fun compose (f, g) c = map f (g c)
1.26 +3 -3 mlton/basis-library/io/stream-io.fun
Index: stream-io.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/io/stream-io.fun,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -r1.25 -r1.26
--- stream-io.fun 11 Feb 2004 21:26:32 -0000 1.25
+++ stream-io.fun 13 Feb 2004 17:05:55 -0000 1.26
@@ -805,9 +805,9 @@
let
val curPos = getPos ()
in
- setPos b;
- readVec pos;
- getPos () before setPos curPos
+ setPos b
+ ; ignore (readVec pos)
+ ; getPos () before setPos curPos
end
| _ =>
liftExn (instreamName is) "filePosIn" IO.RandomAccessNotSupported))
1.9 +9 -7 mlton/basis-library/net/socket.sml
Index: socket.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/net/socket.sml,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- socket.sml 12 Feb 2004 19:04:08 -0000 1.8
+++ socket.sml 13 Feb 2004 17:05:55 -0000 1.9
@@ -252,14 +252,16 @@
in
fun withNonBlock (fd, f: unit -> 'a) =
let
- val flags = PIO.fcntl2 (fd, PIO.F_GETFL)
- val _ = PIO.fcntl3 (fd, PIO.F_SETFL,
- Word.toIntX
- (Word.orb (Word.fromInt flags,
- PosixPrimitive.FileSys.O.nonblock)))
+ val flags = PE.checkReturnResult (PIO.fcntl2 (fd, PIO.F_GETFL))
+ val _ =
+ PE.checkResult
+ (PIO.fcntl3 (fd, PIO.F_SETFL,
+ Word.toIntX
+ (Word.orb (Word.fromInt flags,
+ PosixPrimitive.FileSys.O.nonblock))))
in
- DynamicWind.wind (f, fn () => (PIO.fcntl3 (fd, PIO.F_SETFL, flags)
- ; ()))
+ DynamicWind.wind
+ (f, fn () => PE.checkResult (PIO.fcntl3 (fd, PIO.F_SETFL, flags)))
end
end
1.7 +1 -1 mlton/basis-library/posix/error.sml
Index: error.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/error.sml,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- error.sml 6 Jan 2004 05:12:27 -0000 1.6
+++ error.sml 13 Feb 2004 17:05:55 -0000 1.7
@@ -39,5 +39,5 @@
fun checkReturnResult (n: int) = if n = ~1 then error () else n
fun checkReturnPosition (n: Position.int) =
if n = ~1 then error () else n
- fun checkResult n = (checkReturnResult n; ())
+ fun checkResult n = (ignore (checkReturnResult n); ())
end
1.14 +1 -1 mlton/basis-library/posix/io.sml
Index: io.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/io.sml,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- io.sml 11 Feb 2004 19:16:11 -0000 1.13
+++ io.sml 13 Feb 2004 17:05:55 -0000 1.14
@@ -230,8 +230,8 @@
in
pos := curPos; curPos
end
+ val _ = verifyPos ()
in
- verifyPos ();
{pos = pos,
getPos = SOME getPos,
setPos = SOME setPos,
1.22 +37 -38 mlton/basis-library/posix/primitive.sml
Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/primitive.sml,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- primitive.sml 12 Feb 2004 23:13:38 -0000 1.21
+++ primitive.sml 13 Feb 2004 17:05:55 -0000 1.22
@@ -14,7 +14,6 @@
type fd = int
type uid = word
type gid = word
- type signal = int
type size = int
type ssize = int
type mode = word
@@ -123,14 +122,14 @@
structure Signal:>
sig
- eqtype signal
+ eqtype t
type how
- val fromInt: int -> signal
- val toInt: signal -> int
+ val fromInt: int -> t
+ val toInt: t -> int
end =
struct
- type signal = signal
+ type t = int
type how = int
val fromInt = fn s => s
@@ -141,46 +140,46 @@
struct
open Signal
- val abrt = _const "Posix_Signal_abrt": signal;
- val alrm = _const "Posix_Signal_alrm": signal;
- val bus = _const "Posix_Signal_bus": signal;
- val chld = _const "Posix_Signal_chld": signal;
- val cont = _const "Posix_Signal_cont": signal;
- val fpe = _const "Posix_Signal_fpe": signal;
- val hup = _const "Posix_Signal_hup": signal;
- val ill = _const "Posix_Signal_ill": signal;
- val int = _const "Posix_Signal_int": signal;
- val kill = _const "Posix_Signal_kill": signal;
- val pipe = _const "Posix_Signal_pipe": signal;
- val prof = _const "Posix_Signal_prof": signal;
- val quit = _const "Posix_Signal_quit": signal;
- val segv = _const "Posix_Signal_segv": signal;
- val stop = _const "Posix_Signal_stop": signal;
- val term = _const "Posix_Signal_term": signal;
- val tstp = _const "Posix_Signal_tstp": signal;
- val ttin = _const "Posix_Signal_ttin": signal;
- val ttou = _const "Posix_Signal_ttou": signal;
- val usr1 = _const "Posix_Signal_usr1": signal;
- val usr2 = _const "Posix_Signal_usr2": signal;
- val vtalrm = _const "Posix_Signal_vtalrm": signal;
+ val abrt = _const "Posix_Signal_abrt": t;
+ val alrm = _const "Posix_Signal_alrm": t;
+ val bus = _const "Posix_Signal_bus": t;
+ val chld = _const "Posix_Signal_chld": t;
+ val cont = _const "Posix_Signal_cont": t;
+ val fpe = _const "Posix_Signal_fpe": t;
+ val hup = _const "Posix_Signal_hup": t;
+ val ill = _const "Posix_Signal_ill": t;
+ val int = _const "Posix_Signal_int": t;
+ val kill = _const "Posix_Signal_kill": t;
+ val pipe = _const "Posix_Signal_pipe": t;
+ val prof = _const "Posix_Signal_prof": t;
+ val quit = _const "Posix_Signal_quit": t;
+ val segv = _const "Posix_Signal_segv": t;
+ val stop = _const "Posix_Signal_stop": t;
+ val term = _const "Posix_Signal_term": t;
+ val tstp = _const "Posix_Signal_tstp": t;
+ val ttin = _const "Posix_Signal_ttin": t;
+ val ttou = _const "Posix_Signal_ttou": t;
+ val usr1 = _const "Posix_Signal_usr1": t;
+ val usr2 = _const "Posix_Signal_usr2": t;
+ val vtalrm = _const "Posix_Signal_vtalrm": t;
val block = _const "Posix_Signal_block": how;
- val default = _import "Posix_Signal_default": signal -> int;
+ val default = _import "Posix_Signal_default": t -> int;
val handleGC = _import "Posix_Signal_handleGC": unit -> unit;
- val handlee = _import "Posix_Signal_handle": signal -> int;
- val ignore = _import "Posix_Signal_ignore": signal -> int;
+ val handlee = _import "Posix_Signal_handle": t -> int;
+ val ignore = _import "Posix_Signal_ignore": t -> int;
val isDefault =
- _import "Posix_Signal_isDefault": signal * bool ref -> int;
+ _import "Posix_Signal_isDefault": t * bool ref -> int;
val isGCPending = _import "Posix_Signal_isGCPending": unit -> bool;
- val isPending = _import "Posix_Signal_isPending": signal -> bool;
+ val isPending = _import "Posix_Signal_isPending": t -> bool;
val numSignals = _const "Posix_Signal_numSignals": int;
val setmask = _const "Posix_Signal_setmask": how;
- val sigaddset = _import "Posix_Signal_sigaddset": signal -> int;
- val sigdelset = _import "Posix_Signal_sigdelset": signal -> int;
+ val sigaddset = _import "Posix_Signal_sigaddset": t -> int;
+ val sigdelset = _import "Posix_Signal_sigdelset": t -> int;
val sigemptyset = _import "Posix_Signal_sigemptyset": unit -> int;
val sigfillset = _import "Posix_Signal_sigfillset": unit -> int;
val sigprocmask = _import "Posix_Signal_sigprocmask": how -> int;
- val suspend = _import "Posix_Signal_suspend": unit -> int;
+ val suspend = _import "Posix_Signal_suspend": unit -> unit;
val unblock = _const "Posix_Signal_unblock": how;
end
@@ -209,11 +208,11 @@
val ifSignaled = _import "Posix_Process_ifSignaled"
: Status.t -> bool;
val ifStopped = _import "Posix_Process_ifStopped": Status.t -> bool;
- val kill = _import "Posix_Process_kill": Pid.t * signal -> int;
+ val kill = _import "Posix_Process_kill": Pid.t * Signal.t -> int;
val pause = _import "Posix_Process_pause": unit -> int;
val sleep = _import "Posix_Process_sleep": int -> int;
- val stopSig = _import "Posix_Process_stopSig": Status.t -> signal;
- val termSig = _import "Posix_Process_termSig": Status.t -> signal;
+ val stopSig = _import "Posix_Process_stopSig": Status.t -> Signal.t;
+ val termSig = _import "Posix_Process_termSig": Status.t -> Signal.t;
val waitpid =
_import "Posix_Process_waitpid"
: Pid.t * Status.t ref * int -> Pid.t;
1.18 +8 -8 mlton/basis-library/posix/process.sml
Index: process.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/process.sml,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- process.sml 12 Feb 2004 23:13:38 -0000 1.17
+++ process.sml 13 Feb 2004 17:05:55 -0000 1.18
@@ -18,7 +18,7 @@
val pidToWord = SysWord.fromInt o Pid.toInt
structure MLton = Primitive.MLton
-
+
fun fork () =
let
val p = Prim.fork ()
@@ -49,10 +49,10 @@
fun doit () =
case fork () of
NONE =>
- (PosixIO.writeVec (outfd,
- Word8VectorSlice.full
- (Word8Vector.tabulate
- (1, fn _ => 0w0)))
+ (ignore (PosixIO.writeVec (outfd,
+ Word8VectorSlice.full
+ (Word8Vector.tabulate
+ (1, fn _ => 0w0))))
; NONE)
| SOME n =>
let
@@ -111,9 +111,9 @@
0 => W_EXITED
| n => W_EXITSTATUS (Word8.fromInt n))
else if Prim.ifSignaled status
- then W_SIGNALED (PosixSignal.fromInt (Prim.termSig status))
+ then W_SIGNALED (Prim.termSig status)
else if Prim.ifStopped status
- then W_STOPPED (PosixSignal.fromInt (Prim.stopSig status))
+ then W_STOPPED (Prim.stopSig status)
else raise Fail "Posix.Process.fromStatus"
structure W =
@@ -178,7 +178,7 @@
| K_SAME_GROUP => ~1
| K_GROUP pid => ~ (Pid.toInt pid)
in
- Error.checkResult (Prim.kill (Pid.fromInt pid, PosixSignal.toInt s))
+ Error.checkResult (Prim.kill (Pid.fromInt pid, s))
end
local
1.4 +2 -0 mlton/basis-library/posix/signal.sml
Index: signal.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/signal.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- signal.sml 6 Jan 2004 00:00:19 -0000 1.3
+++ signal.sml 13 Feb 2004 17:05:55 -0000 1.4
@@ -9,6 +9,8 @@
struct
open PosixPrimitive.Signal
+ type signal = t
+
val fromWord = fromInt o SysWord.toInt
val toWord = SysWord.fromInt o toInt
end
1.6 +2 -2 mlton/basis-library/posix/tty.sml
Index: tty.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/tty.sml,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- tty.sml 11 Feb 2004 19:16:11 -0000 1.5
+++ tty.sml 13 Feb 2004 17:05:55 -0000 1.6
@@ -134,8 +134,8 @@
; Termios.setoflag oflag
; Termios.setcflag cflag
; Termios.setlflag lflag
- ; Termios.setospeed ospeed
- ; Termios.setispeed ispeed
+ ; PosixError.checkResult (Termios.setospeed ospeed)
+ ; PosixError.checkResult (Termios.setispeed ispeed)
; let val cs = Termios.cc ()
in Util.naturalForeach
(V.nccs, fn i => Cstring.update (cs, i, V.sub (cc, i)))
1.8 +4 -4 mlton/basis-library/real/pack-real.sml
Index: pack-real.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/real/pack-real.sml,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- pack-real.sml 27 Dec 2003 06:02:37 -0000 1.7
+++ pack-real.sml 13 Feb 2004 17:05:55 -0000 1.8
@@ -19,9 +19,9 @@
fun update (a, i, r) =
let
val a = Word8Array.toPoly a
+ val _ = Array.checkSlice (a, i, SOME bytesPerElem)
in
- Array.checkSlice (a, i, SOME bytesPerElem)
- ; up (a, i, r)
+ up (a, i, r)
end
local
@@ -35,9 +35,9 @@
fun subVec (v, i) =
let
val v = Word8Vector.toPoly v
+ val _ = Vector.checkSlice (v, i, SOME bytesPerElem)
in
- Vector.checkSlice (v, i, SOME bytesPerElem)
- ; sub (v, i)
+ sub (v, i)
end
fun fromBytes v = subVec (v, 0)
1.13 +1 -1 mlton/basis-library/system/process.sml
Index: process.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/system/process.sml,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- process.sml 12 Feb 2004 23:13:38 -0000 1.12
+++ process.sml 13 Feb 2004 17:05:55 -0000 1.13
@@ -63,5 +63,5 @@
fun sleep t = if Time.<= (t, Time.zeroTime)
then ()
- else (Posix.Process.sleep t; ())
+ else (ignore (Posix.Process.sleep t); ())
end
1.14 +3 -1 mlton/basis-library/system/time.sml
Index: time.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/system/time.sml,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- time.sml 16 Nov 2003 14:21:08 -0000 1.13
+++ time.sml 13 Feb 2004 17:05:55 -0000 1.14
@@ -63,7 +63,9 @@
*)
local
fun getNow (): time =
- (Prim.gettimeofday ()
+ (if ~1 = Prim.gettimeofday ()
+ then raise Fail "Time.now"
+ else ()
; T (LargeInt.+ (LargeInt.* (LargeInt.fromInt (Prim.sec ()),
ticksPerSecond),
LargeInt.fromInt (Prim.usec ()))))
1.103 +4 -0 mlton/doc/changelog
Index: changelog
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/changelog,v
retrieving revision 1.102
retrieving revision 1.103
diff -u -r1.102 -r1.103
--- changelog 10 Feb 2004 12:05:37 -0000 1.102
+++ changelog 13 Feb 2004 17:05:55 -0000 1.103
@@ -1,5 +1,9 @@
Here are the changes since version 20030716.
+* 2004-02-13
+ - Added flag -sequence-unit, which imposes the constraint that in
+ the sequence expression (e1; e2), e1 must be of type unit.
+
* 2004-02-10
- Lots of changes to MLton.Signal: name changes, removal of
superfluous functions, additional functions.
1.48 +6 -0 mlton/doc/user-guide/man-page.tex
Index: man-page.tex
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/user-guide/man-page.tex,v
retrieving revision 1.47
retrieving revision 1.48
diff -u -r1.47 -r1.48
--- man-page.tex 10 Feb 2004 12:05:37 -0000 1.47
+++ man-page.tex 13 Feb 2004 17:05:56 -0000 1.48
@@ -134,6 +134,12 @@
does not conform to the basis library specification, and may cause
programs to seg fault.
+\option{-sequence-unit \falseTrue}
+If true, then in the sequence expression {\tt (e1; e2)}, it is a type
+error if {\tt e1} is not of type {\tt unit}. This can be helpful in
+detecting curried applications that are mistakenly not fully applied.
+To silence spurious errors, you can use {\tt ignore e1}.
+
\option{-show-basis \falseTrue}
If true, {\mlton} prints the basis library and exits. When used with
an input file, {\mlton} prints the basis defined by the input program.
1.9 +3 -3 mlton/lib/mlton/basic/hash-set.sml
Index: hash-set.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/hash-set.sml,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- hash-set.sml 30 Jan 2003 01:42:38 -0000 1.8
+++ hash-set.sml 13 Feb 2004 17:05:56 -0000 1.9
@@ -204,9 +204,9 @@
val s = new {hash = hash}
val _ =
List.foreach (l, fn a =>
- (lookupOrInsert (s, hash a,
- fn b => equals (a, b),
- fn _ => a)
+ (ignore (lookupOrInsert (s, hash a,
+ fn b => equals (a, b),
+ fn _ => a))
; ()))
in
s
1.43 +7 -0 mlton/man/mlton.1
Index: mlton.1
===================================================================
RCS file: /cvsroot/mlton/mlton/man/mlton.1,v
retrieving revision 1.42
retrieving revision 1.43
diff -u -r1.42 -r1.43
--- mlton.1 10 Feb 2004 12:05:38 -0000 1.42
+++ mlton.1 13 Feb 2004 17:05:56 -0000 1.43
@@ -141,6 +141,13 @@
specification, and may cause programs to seg fault.
.TP
+\fB-sequence-unit \fI{\fBfalse\fP|\fBtrue\fP}\fR
+If true, then in the sequence expression \fB(e1; e2)\fP, it is a type
+error if \fBe1\fP is not of type \fB unit\fP. This can be helpful in
+detecting curried applications that are mistakenly not fully applied.
+To silence spurious errors, you can use \fBignore e1\fP.
+
+.TP
\fB-show-basis \fI{\fBfalse\fP|\fBtrue\fP}\fR
If true, \fBMLton\fP prints the basis library and exits. When used
with an input file, \fBmlton\fP prints the basis defined by the input
1.89 +3 -0 mlton/mlton/control/control.sig
Index: control.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sig,v
retrieving revision 1.88
retrieving revision 1.89
diff -u -r1.88 -r1.89
--- control.sig 31 Jan 2004 06:36:12 -0000 1.88
+++ control.sig 13 Feb 2004 17:05:56 -0000 1.89
@@ -211,6 +211,9 @@
(* Array bounds checking. *)
val safe: bool ref
+ (* in (e1; e2), require e1: unit. *)
+ val sequenceUnit: bool ref
+
(* Show the basis library and exit. *)
val showBasis: bool ref
1.109 +4 -0 mlton/mlton/control/control.sml
Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.108
retrieving revision 1.109
diff -u -r1.108 -r1.109
--- control.sml 31 Jan 2004 06:36:12 -0000 1.108
+++ control.sml 13 Feb 2004 17:05:56 -0000 1.109
@@ -393,6 +393,10 @@
default = true,
toString = Bool.toString}
+val sequenceUnit = control {name = "sequence unit",
+ default = false,
+ toString = Bool.toString}
+
val showBasis = control {name = "show basis",
default = false,
toString = Bool.toString}
1.83 +34 -6 mlton/mlton/elaborate/elaborate-core.fun
Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.82
retrieving revision 1.83
diff -u -r1.82 -r1.83
--- elaborate-core.fun 6 Feb 2004 23:00:30 -0000 1.82
+++ elaborate-core.fun 13 Feb 2004 17:05:56 -0000 1.83
@@ -306,7 +306,7 @@
val unify =
fn (t, t', preError, error) =>
- Type.unify (t, t', {error = error,
+ Type.unify (t, t', {error = Control.error o error,
preError = preError})
fun unifyList (trs: (Type.t * Region.t) vector,
@@ -2120,12 +2120,40 @@
| Aexp.Selector f => elab (Aexp.selector (f, region))
| Aexp.Seq es =>
let
- val es = Vector.map (es, elab)
- (* Could put warning here for expressions before a ; that
- * don't return unit.
- *)
+ val es' = Vector.map (es, elab)
+ val last = Vector.length es - 1
+ (* Warning for expressions before a ; that don't return
+ * unit.
+ *)
+ val _ =
+ if not (!Control.sequenceUnit)
+ then ()
+ else
+ Vector.foreachi
+ (es', fn (i, e) =>
+ if i = last
+ then ()
+ else
+ let
+ fun error _ =
+ let
+ val e = Vector.sub (es, i)
+ open Layout
+ in
+ Control.warning
+ (Aexp.region e,
+ str "sequence expression not of type unit",
+ seq [str "in: ",
+ approximate (Aexp.layout e)])
+ end
+ in
+ Type.unify (Cexp.ty e, Type.unit,
+ {error = error,
+ preError = preError})
+ end)
+
in
- Cexp.make (Cexp.Seq es, Cexp.ty (Vector.last es))
+ Cexp.make (Cexp.Seq es', Cexp.ty (Vector.sub (es', last)))
end
| Aexp.Var {name = id, ...} =>
let
1.66 +2 -0 mlton/mlton/elaborate/elaborate-env.fun
Index: elaborate-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.fun,v
retrieving revision 1.65
retrieving revision 1.66
diff -u -r1.65 -r1.66
--- elaborate-env.fun 12 Feb 2004 22:21:08 -0000 1.65
+++ elaborate-env.fun 13 Feb 2004 17:05:56 -0000 1.66
@@ -1563,6 +1563,7 @@
let
open Layout
in
+ Control.error
(r,
seq [str (concat [thing, " in structure disagrees with ",
sign])],
@@ -1851,6 +1852,7 @@
let
open Layout
in
+ Control.error
(region,
seq [str "variable type in structure disagrees with ",
str sign],
1.26 +3 -4 mlton/mlton/elaborate/type-env.fun
Index: type-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-env.fun,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -r1.25 -r1.26
--- type-env.fun 4 Feb 2004 15:33:13 -0000 1.25
+++ type-env.fun 13 Feb 2004 17:05:56 -0000 1.26
@@ -1724,11 +1724,10 @@
end
val unify =
- fn (t1: t, t2: t,
- {error: Layout.t * Layout.t -> Region.t * Layout.t * Layout.t,
- preError: unit -> unit}) =>
+ fn (t1: t, t2: t, {error: Layout.t * Layout.t -> unit,
+ preError: unit -> unit}) =>
case unify (t1, t2, {preError = preError}) of
- NotUnifiable z => Control.error (error z)
+ NotUnifiable z => error z
| Unified => ()
end
1.16 +2 -4 mlton/mlton/elaborate/type-env.sig
Index: type-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-env.sig,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- type-env.sig 3 Feb 2004 07:26:34 -0000 1.15
+++ type-env.sig 13 Feb 2004 17:05:56 -0000 1.16
@@ -50,10 +50,8 @@
val toString: t -> string
(* make two types identical (recursively). side-effecting. *)
val unify:
- t * t *
- {error: Layout.t * Layout.t -> Region.t * Layout.t * Layout.t,
- preError: unit -> unit}
- -> unit
+ t * t * {error: Layout.t * Layout.t -> unit,
+ preError: unit -> unit} -> unit
val unresolvedInt: unit -> t
val unresolvedReal: unit -> t
val unresolvedWord: unit -> t
1.25 +3 -0 mlton/mlton/main/main.fun
Index: main.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.fun,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -r1.24 -r1.25
--- main.fun 11 Feb 2004 17:58:43 -0000 1.24
+++ main.fun 13 Feb 2004 17:05:57 -0000 1.25
@@ -320,6 +320,9 @@
push runtimeArgs),
(Normal, "safe", " {true|false}", "bounds checking and other checks",
boolRef safe),
+ (Normal, "sequence-unit", " {false|true}",
+ "in (e1; e2), require e1: unit",
+ boolRef sequenceUnit),
(Normal, "show-basis", " {false|true}", "display the basis library",
boolRef showBasis),
(Normal, "show-basis-used", " {false|true}",