[MLton-commit] r7398
Matthew Fluet
fluet at mlton.org
Tue Jan 19 10:58:55 PST 2010
Additional signal handling regression tests.
signals3: check signal handling while busy-waiting in mutator
signals4: check inheritance of signal handlers by forked process
----------------------------------------------------------------------
U mlton/trunk/bin/regression
U mlton/trunk/regression/signals.sml
A mlton/trunk/regression/signals3.ok
A mlton/trunk/regression/signals3.sml
A mlton/trunk/regression/signals4.ok
A mlton/trunk/regression/signals4.sml
----------------------------------------------------------------------
Modified: mlton/trunk/bin/regression
===================================================================
--- mlton/trunk/bin/regression 2010-01-19 18:58:43 UTC (rev 7397)
+++ mlton/trunk/bin/regression 2010-01-19 18:58:50 UTC (rev 7398)
@@ -91,7 +91,7 @@
cont='callcc.sml callcc2.sml callcc3.sml once.sml'
flatArray='finalize.sml flat-array.sml flat-array.2.sml'
intInf='conv.sml conv2.sml fixed-integer.sml harmonic.sml int-inf.*.sml slow.sml slower.sml smith-normal-form.sml'
-signal='finalize.sml signals.sml signals2.sml suspend.sml weak.sml'
+signal='finalize.sml signals.sml signals2.sml signals3.sml signals4.sml suspend.sml weak.sml'
thread='thread0.sml thread1.sml thread2.sml mutex.sml prodcons.sml same-fringe.sml timeout.sml'
world='world1.sml world2.sml world3.sml world4.sml world5.sml world6.sml'
tmp=/tmp/z.regression.$$
@@ -159,14 +159,14 @@
hurd)
# Work-around hurd bug (http://bugs.debian.org/551470)
case "$f" in
- mutex|prodcons|signals|signals2|suspend|thread2|timeout|world5)
+ mutex|prodcons|signals|signals2|signals3|signals4|suspend|thread2|timeout|world5)
continue
;;
esac
;;
mingw)
case "$f" in
- cmdline|command-line|echo|filesys|posix-exit|signals|signals2|socket|suspend|textio.2|unixpath|world*)
+ cmdline|command-line|echo|filesys|posix-exit|signals|signals2|signals3|signals4|socket|suspend|textio.2|unixpath|world*)
continue
;;
esac
Modified: mlton/trunk/regression/signals.sml
===================================================================
--- mlton/trunk/regression/signals.sml 2010-01-19 18:58:43 UTC (rev 7397)
+++ mlton/trunk/regression/signals.sml 2010-01-19 18:58:50 UTC (rev 7398)
@@ -5,7 +5,7 @@
fun foreach (l, f) = app f l
end
structure Process = Posix.Process
-open Process Posix.Signal MLton.Signal
+open Process Posix.Signal MLton.Signal
fun print s = let open TextIO
in output (stdErr, s)
@@ -13,7 +13,7 @@
end
val sleep = sleep o Time.fromSeconds
-
+
val _ =
case fork () of
NONE =>
@@ -28,10 +28,10 @@
fun loop' () = (sleep 1; loop' ())
in loop' ()
end
- | SOME pid =>
+ | SOME pid =>
let
fun signal s = Process.kill (K_PROC pid, s)
- in
+ in
sleep 1
; print "sending 1"
; List.foreach ([hup, int, term], signal)
@@ -43,4 +43,3 @@
; signal kill
; wait ()
end
-
Added: mlton/trunk/regression/signals3.ok
===================================================================
--- mlton/trunk/regression/signals3.ok 2010-01-19 18:58:43 UTC (rev 7397)
+++ mlton/trunk/regression/signals3.ok 2010-01-19 18:58:50 UTC (rev 7398)
@@ -0,0 +1,8 @@
+sending 1
+Got a hup.
+You can't int me you loser.
+Don't even try to term me.
+sending 2
+Got a hup.
+You can't int me you loser.
+sending 3
Copied: mlton/trunk/regression/signals3.sml (from rev 7397, mlton/trunk/regression/signals.sml)
===================================================================
--- mlton/trunk/regression/signals.sml 2010-01-19 18:58:43 UTC (rev 7397)
+++ mlton/trunk/regression/signals3.sml 2010-01-19 18:58:50 UTC (rev 7398)
@@ -0,0 +1,45 @@
+structure List =
+ struct
+ open List
+
+ fun foreach (l, f) = app f l
+ end
+structure Process = Posix.Process
+open Process Posix.Signal MLton.Signal
+
+fun print s = let open TextIO
+ in output (stdErr, s)
+ ; output (stdErr, "\n")
+ end
+
+val sleep = sleep o Time.fromSeconds
+
+val _ =
+ case fork () of
+ NONE =>
+ let
+ val _ =
+ List.foreach
+ ([(hup, "Got a hup."),
+ (int, "You can't int me you loser."),
+ (term, "Don't even try to term me.")],
+ fn (signal, msg) =>
+ setHandler (signal, Handler.simple (fn () => print msg)))
+ fun loop' () = loop' ()
+ in loop' ()
+ end
+ | SOME pid =>
+ let
+ fun signal s = Process.kill (K_PROC pid, s)
+ in
+ sleep 1
+ ; print "sending 1"
+ ; List.foreach ([hup, int, term], signal)
+ ; sleep 3
+ ; print "sending 2"
+ ; List.foreach ([hup, int], signal)
+ ; sleep 3
+ ; print "sending 3"
+ ; signal kill
+ ; wait ()
+ end
Added: mlton/trunk/regression/signals4.ok
===================================================================
--- mlton/trunk/regression/signals4.ok 2010-01-19 18:58:43 UTC (rev 7397)
+++ mlton/trunk/regression/signals4.ok 2010-01-19 18:58:50 UTC (rev 7398)
@@ -0,0 +1,8 @@
+sending 1
+Got a hup.
+You can't int me you loser.
+Don't even try to term me.
+sending 2
+Got a hup.
+You can't int me you loser.
+sending 3
Copied: mlton/trunk/regression/signals4.sml (from rev 7397, mlton/trunk/regression/signals.sml)
===================================================================
--- mlton/trunk/regression/signals.sml 2010-01-19 18:58:43 UTC (rev 7397)
+++ mlton/trunk/regression/signals4.sml 2010-01-19 18:58:50 UTC (rev 7398)
@@ -0,0 +1,45 @@
+structure List =
+ struct
+ open List
+
+ fun foreach (l, f) = app f l
+ end
+structure Process = Posix.Process
+open Process Posix.Signal MLton.Signal
+
+fun print s = let open TextIO
+ in output (stdErr, s)
+ ; output (stdErr, "\n")
+ end
+
+val sleep = sleep o Time.fromSeconds
+
+val _ =
+ List.foreach
+ ([(hup, "Got a hup."),
+ (int, "You can't int me you loser."),
+ (term, "Don't even try to term me.")],
+ fn (signal, msg) =>
+ setHandler (signal, Handler.simple (fn () => print msg)))
+
+val _ =
+ case fork () of
+ NONE =>
+ let fun loop' () = loop' ()
+ in loop' ()
+ end
+ | SOME pid =>
+ let
+ fun signal s = Process.kill (K_PROC pid, s)
+ in
+ sleep 1
+ ; print "sending 1"
+ ; List.foreach ([hup, int, term], signal)
+ ; sleep 3
+ ; print "sending 2"
+ ; List.foreach ([hup, int], signal)
+ ; sleep 3
+ ; print "sending 3"
+ ; signal kill
+ ; wait ()
+ end
More information about the MLton-commit
mailing list