[MLton] cvs commit: MAIL: PosixError.SysCall changes
Matthew Fluet
fluet@mlton.org
Sat, 1 May 2004 13:11:40 -0700
fluet 04/05/01 13:11:40
Modified: regression signals2.sml
runtime/basis/Net NetHostDB.c
basis-library/mlton proc-env.sml process.sml rlimit.sml
signal.sml thread.sml
basis-library/net generic-sock.sml net-host-db.sml
socket.sml
basis-library/posix error.sig error.sml file-sys.sml io.sml
proc-env.sml process.sml sys-db.sml tty.sml
basis-library/system io.sml
Log:
MAIL: PosixError.SysCall changes
Replaced most PosixError.* uses with calls to PosixError.SysCall.*.
The exception is in net/socket.sml, which requires some more thought
to implement correctly.
PosixError.SysCall mediates _all_ access to errno.
PosixError.SysCall.syscallErr is the most general interface, with the
other PosixError.SysCall.* functions as special cases.
Revision Changes Path
1.3 +1 -12 mlton/regression/signals2.sml
Index: signals2.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/signals2.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- signals2.sml 29 Mar 2004 13:07:38 -0000 1.2
+++ signals2.sml 1 May 2004 20:11:38 -0000 1.3
@@ -3,25 +3,14 @@
val atomicBegin : unit -> unit
val atomicEnd : unit -> unit
val doAtomic : (unit -> unit) -> unit
-
- val maskBegin : unit -> unit
- val maskEnd : unit -> unit
- val doMasked : (unit -> unit) -> unit
end
structure Critical : CRITICAL =
struct
structure Thread = MLton.Thread
- structure Signal = MLton.Signal
- structure Itimer = MLton.Itimer
val atomicBegin = Thread.atomicBegin
val atomicEnd = Thread.atomicEnd
fun doAtomic f = (atomicBegin (); f (); atomicEnd ())
-
- val mask = Signal.Mask.some [Itimer.signal Itimer.Real]
- fun maskBegin () = Signal.Mask.block mask
- fun maskEnd () = Signal.Mask.unblock mask
- fun doMasked f = (maskBegin (); f (); maskEnd ())
end
structure Main =
@@ -38,7 +27,7 @@
Signal.setHandler (Itimer.signal Itimer.Real, h)
fun print s =
- Critical.doMasked (fn () => (MLton.GC.collect (); TextIO.print s))
+ Critical.doAtomic (fn () => TextIO.print s)
fun doit n =
let
1.4 +2 -2 mlton/runtime/basis/Net/NetHostDB.c
Index: NetHostDB.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Net/NetHostDB.c,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- NetHostDB.c 15 Jan 2003 19:17:57 -0000 1.3
+++ NetHostDB.c 1 May 2004 20:11:38 -0000 1.4
@@ -42,12 +42,12 @@
return;
}
-Int NetHostDB_getByAddress(Pointer addr, Int len) {
+Bool NetHostDB_getByAddress(Pointer addr, Int len) {
hostent = gethostbyaddr(addr, len, AF_INET);
return (hostent != NULL and hostent->h_name != NULL);
}
-Int NetHostDB_getByName(Cstring name) {
+Bool NetHostDB_getByName(Cstring name) {
hostent = gethostbyname((char*)name);
return (hostent != NULL and hostent->h_name != NULL);
}
1.4 +7 -3 mlton/basis-library/mlton/proc-env.sml
Index: proc-env.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/proc-env.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- proc-env.sml 20 Feb 2004 19:17:32 -0000 1.3
+++ proc-env.sml 1 May 2004 20:11:39 -0000 1.4
@@ -1,7 +1,11 @@
structure MLtonProcEnv: MLTON_PROC_ENV =
struct
fun setenv {name, value} =
- PosixError.checkResult
- (PosixPrimitive.ProcEnv.setenv
- (NullString.nullTerm name, NullString.nullTerm value))
+ let
+ val name = NullString.nullTerm name
+ val value = NullString.nullTerm value
+ in
+ PosixError.SysCall.simple
+ (fn () => PosixPrimitive.ProcEnv.setenv (name, value))
+ end
end
1.13 +16 -10 mlton/basis-library/mlton/process.sml
Index: process.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/process.sml,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- process.sml 20 Feb 2004 19:17:32 -0000 1.12
+++ process.sml 1 May 2004 20:11:39 -0000 1.13
@@ -2,6 +2,7 @@
struct
structure Prim = Primitive.MLton.Process
structure Error = PosixError
+ structure SysCall = Error.SysCall
structure MLton = Primitive.MLton
structure Status = PosixPrimitive.Process.Status
@@ -13,13 +14,15 @@
if isCygwin
then
let
- val pid =
- Prim.spawne (NullString.fromString (String.nullTerm path),
- C.CSS.fromList args,
- C.CSS.fromList env)
- val _ = Error.checkResult (Pid.toInt pid)
+ val path = NullString.nullTerm path
+ val args = C.CSS.fromList args
+ val env = C.CSS.fromList env
in
- pid
+ SysCall.syscall
+ (fn () =>
+ let val pid = Prim.spawne (path, args, env)
+ in (Pid.toInt pid, fn () => pid)
+ end)
end
else
case Posix.Process.fork () of
@@ -33,11 +36,14 @@
if isCygwin
then
let
- val pid = Prim.spawnp (NullString.nullTerm file,
- C.CSS.fromList args)
- val _ = Error.checkResult (Pid.toInt pid)
+ val file = NullString.nullTerm file
+ val args = C.CSS.fromList args
in
- pid
+ SysCall.syscall
+ (fn () =>
+ let val pid = Prim.spawnp (file, args)
+ in (Pid.toInt pid, fn () => pid)
+ end)
end
else
case Posix.Process.fork () of
1.4 +7 -4 mlton/basis-library/mlton/rlimit.sml
Index: rlimit.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/rlimit.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- rlimit.sml 8 Jul 2003 01:29:31 -0000 1.3
+++ rlimit.sml 1 May 2004 20:11:39 -0000 1.4
@@ -4,11 +4,14 @@
val get =
fn (r: t) =>
- (PosixError.checkResult (get r)
- ; {hard = getHard (),
- soft = getSoft ()})
+ PosixError.SysCall.syscall
+ (fn () =>
+ (get r, fn () =>
+ {hard = getHard (),
+ soft = getSoft ()}))
val set =
fn (r: t, {hard, soft}) =>
- PosixError.checkResult (set (r, hard, soft))
+ PosixError.SysCall.simple
+ (fn () => set (r, hard, soft))
end
1.33 +9 -9 mlton/basis-library/mlton/signal.sml
Index: signal.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/signal.sml,v
retrieving revision 1.32
retrieving revision 1.33
diff -u -r1.32 -r1.33
--- signal.sml 30 Apr 2004 01:07:14 -0000 1.32
+++ signal.sml 1 May 2004 20:11:39 -0000 1.33
@@ -140,15 +140,6 @@
case h of
Handler _ => (fromInt s)::sigs
| _ => sigs) [] handlers)
-
- val () =
- PosixError.SysCall.blocker :=
- (fn () => let
- val m = getBlocked ()
- val () = block (handled ())
- in
- fn () => setBlocked m
- end)
end
structure Handler =
@@ -175,6 +166,15 @@
* Any exceptions raised by a signal handler will be caught by
* the topLevelHandler, which is installed in thread.sml.
*)
+ val _ =
+ PosixError.SysCall.blocker :=
+ (fn () => let
+ val m = Mask.getBlocked ()
+ val () = Mask.block (Mask.handled ())
+ in
+ fn () => Mask.setBlocked m
+ end)
+
val () =
MLtonThread.setHandler
(fn t =>
1.27 +1 -1 mlton/basis-library/mlton/thread.sml
Index: thread.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/thread.sml,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -r1.26 -r1.27
--- thread.sml 1 May 2004 00:33:45 -0000 1.26
+++ thread.sml 1 May 2004 20:11:39 -0000 1.27
@@ -262,7 +262,7 @@
(* Atomic 0 *)
val () = atomicBegin ()
(* Atomic 1 *)
- val () = Prim.startHandler ()
+ val () = Prim.startHandler () (* implicit atomicBegin () *)
(* Atomic 2 *)
in
case !signalHandler of
1.4 +18 -14 mlton/basis-library/net/generic-sock.sml
Index: generic-sock.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/net/generic-sock.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- generic-sock.sml 12 Feb 2004 19:03:39 -0000 1.3
+++ generic-sock.sml 1 May 2004 20:11:39 -0000 1.4
@@ -2,26 +2,30 @@
struct
structure Prim = Primitive.Socket.GenericSock
structure PE = Posix.Error
+ structure PESC = PE.SysCall
fun intToSock i = Socket.wordToSock (SysWord.fromInt i)
fun socket' (af, st, p) =
- intToSock
- (PE.checkReturnResult
- (Prim.socket (NetHostDB.addrFamilyToInt af, st, p)))
+ PESC.syscall
+ (fn () =>
+ let val n = Prim.socket (NetHostDB.addrFamilyToInt af, st, p)
+ in (n, fn () => intToSock n)
+ end)
fun socketPair' (af, st, p) =
- let
- val s1 = ref 0
- val s2 = ref 0
- val _ =
- PE.checkResult
- (Prim.socketPair (NetHostDB.addrFamilyToInt af, st, p, s1, s2))
- in
- (intToSock (!s1), intToSock (!s2))
- end
-
+ let
+ val s1 = ref 0
+ val s2 = ref 0
+ in
+ PESC.syscall
+ (fn () =>
+ let val n = Prim.socketPair (NetHostDB.addrFamilyToInt af, st, p, s1, s2)
+ in (n, fn () => (intToSock (!s1), intToSock (!s2)))
+ end)
+ end
+
fun socket (af, st) = socket' (af, st, 0)
-
+
fun socketPair (af, st) = socketPair' (af, st, 0)
end
1.12 +3 -2 mlton/basis-library/net/net-host-db.sml
Index: net-host-db.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/net/net-host-db.sml,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- net-host-db.sml 20 Feb 2004 19:17:32 -0000 1.11
+++ net-host-db.sml 1 May 2004 20:11:39 -0000 1.12
@@ -97,8 +97,9 @@
let
val n = 128
val buf = CharArray.array (n, #"\000")
- val _ =
- Posix.Error.checkResult (Prim.getHostName (CharArray.toPoly buf, n))
+ val () =
+ Posix.Error.SysCall.simple
+ (fn () => Prim.getHostName (CharArray.toPoly buf, n))
in
case CharArray.findi (fn (_, c) => c = #"\000") buf of
NONE => CharArray.vector buf
1.12 +32 -23 mlton/basis-library/net/socket.sml
Index: socket.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/net/socket.sml,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- socket.sml 16 Feb 2004 23:32:08 -0000 1.11
+++ socket.sml 1 May 2004 20:11:39 -0000 1.12
@@ -6,6 +6,8 @@
structure Prim = Primitive.Socket
structure PE = Posix.Error
+structure PEO = PE.Old
+structure PESC = PE.SysCall
structure PFS = Posix.FileSys
datatype sock = S of Prim.sock
@@ -131,8 +133,9 @@
val optval = Word8Array.array (optlen, 0wx0)
val optlen = ref optlen
in
- PE.checkResult
- (Prim.Ctl.getSockOpt (s, level, optname,
+ PESC.simple
+ (fn () =>
+ Prim.Ctl.getSockOpt (s, level, optname,
Word8Array.toPoly optval,
optlen))
; unmarshal (optval, !optlen, 0)
@@ -142,8 +145,9 @@
val optval = marshal optval
val optlen = Word8Vector.length optval
in
- PE.checkResult
- (Prim.Ctl.setSockOpt (s, level, optname,
+ PESC.simple
+ (fn () =>
+ Prim.Ctl.setSockOpt (s, level, optname,
Word8Vector.toPoly optval,
optlen))
end
@@ -151,16 +155,20 @@
let
val optval = Word8Array.array (optlen, 0wx0)
in
- PE.checkResult (Prim.Ctl.getIOCtl
- (s, request, Word8Array.toPoly optval))
+ PESC.simple
+ (fn () =>
+ Prim.Ctl.getIOCtl
+ (s, request, Word8Array.toPoly optval))
; unmarshal (optval, optlen, 0)
end
fun setIOCtl (request: request) (S s, optval: 'a): unit =
let
val optval = marshal optval
in
- PE.checkResult (Prim.Ctl.setIOCtl
- (s, request, Word8Vector.toPoly optval))
+ PESC.simple
+ (fn () =>
+ Prim.Ctl.setIOCtl
+ (s, request, Word8Vector.toPoly optval))
end
in
(getSockOpt, getIOCtl, setSockOpt, setIOCtl)
@@ -206,7 +214,7 @@
(S s) =
let
val (sa, salen, finish) = new_sock_addr ()
- val _ = PE.checkResult (f (s, sa, salen))
+ val () = PESC.simple (fn () => f (s, sa, salen))
in
finish ()
end
@@ -223,15 +231,16 @@
fun familyOfAddr (SA sa) = NetHostDB.intToAddrFamily (Prim.familyOfAddr sa)
fun bind (S s, SA sa) =
- PE.checkResult (Prim.bind (s, sa, Vector.length sa))
+ PESC.simple (fn () => Prim.bind (s, sa, Vector.length sa))
-fun listen (S s, n) = PE.checkResult (Prim.listen (s, n))
+fun listen (S s, n) =
+ PESC.simple (fn () => Prim.listen (s, n))
fun nonBlock' (res: int, again, no, f) =
if ~1 = res
then
let
- val e = PE.getErrno ()
+ val e = PEO.getErrno ()
in
if e = again
then no
@@ -246,21 +255,21 @@
in
fun withNonBlock (fd, f: unit -> 'a) =
let
- val flags = PE.checkReturnResult (PIO.fcntl2 (fd, PIO.F_GETFL))
+ val flags = PEO.checkReturnResult (PIO.fcntl2 (fd, PIO.F_GETFL))
val _ =
- PE.checkResult
+ PEO.checkResult
(PIO.fcntl3 (fd, PIO.F_SETFL,
Word.toIntX
(Word.orb (Word.fromInt flags,
PosixPrimitive.FileSys.O.nonblock))))
in
DynamicWind.wind
- (f, fn () => PE.checkResult (PIO.fcntl3 (fd, PIO.F_SETFL, flags)))
+ (f, fn () => PEO.checkResult (PIO.fcntl3 (fd, PIO.F_SETFL, flags)))
end
end
fun connect (S s, SA sa) =
- PE.checkResult (Prim.connect (s, sa, Vector.length sa))
+ PEO.checkResult (Prim.connect (s, sa, Vector.length sa))
fun connectNB (S s, SA sa) =
nonBlock' (withNonBlock (s, fn () => Prim.connect (s, sa, Vector.length sa)),
@@ -271,7 +280,7 @@
fun accept (S s) =
let
val (sa, salen, finish) = new_sock_addr ()
- val s = PE.checkReturnResult (Prim.accept (s, sa, salen))
+ val s = PEO.checkReturnResult (Prim.accept (s, sa, salen))
in
(S s, finish ())
end
@@ -285,7 +294,7 @@
fn s => SOME (S s, finish ()))
end
-fun close (S s) = PE.checkResult (Prim.close (s))
+fun close (S s) = PEO.checkResult (Prim.close (s))
datatype shutdown_mode = NO_RECVS | NO_SENDS | NO_RECVS_OR_SENDS
@@ -296,7 +305,7 @@
| NO_RECVS_OR_SENDS => Prim.SHUT_RDWR
fun shutdown (S s, m) =
- PE.checkResult
+ PEO.checkResult
(Prim.shutdown (s, shutdownModeToHow m))
type sock_desc = OS.IO.iodesc
@@ -365,7 +374,7 @@
let
val (buf, i, sz) = base sl
in
- PE.checkReturnResult
+ PEO.checkReturnResult
(primSend (s, buf, i, sz, mk_out_flags out_flags))
end
fun send (sock, buf) = send' (sock, buf, no_out_flags)
@@ -383,7 +392,7 @@
let
val (buf, i, sz) = base sl
in
- PE.checkResult
+ PEO.checkResult
(primSendTo (s, buf, i, sz, mk_out_flags out_flags, sa,
Vector.length sa))
end
@@ -430,7 +439,7 @@
let
val (buf, i, sz) = Word8ArraySlice.base sl
in
- PE.checkReturnResult
+ PEO.checkReturnResult
(Prim.recv (s, Word8Array.toPoly buf, i, sz, mk_in_flags in_flags))
end
@@ -457,7 +466,7 @@
val (buf, i, sz) = Word8ArraySlice.base sl
val (sa, salen, finish) = new_sock_addr ()
val n =
- PE.checkReturnResult
+ PEO.checkReturnResult
(Prim.recvFrom
(s, Word8Array.toPoly buf, i, sz, mk_in_flags in_flags, sa, salen))
in
1.5 +38 -9 mlton/basis-library/posix/error.sig
Index: error.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/error.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- error.sig 30 Apr 2004 01:07:15 -0000 1.4
+++ error.sig 1 May 2004 20:11:39 -0000 1.5
@@ -61,25 +61,54 @@
exception SysErr of string * syserror option
+ val cleared: syserror
+
val raiseSys: syserror -> 'a
- (* raises SysErr with ERRNO *)
- (* raiseSys if arg is -1 *)
- val checkResult: int -> unit
- val checkReturnResult: int -> int
- val checkReturnPosition: Position.int -> Position.int
- val getErrno: unit -> int
- val clearErrno: unit -> unit
- val error: unit -> 'a
+ structure Old:
+ sig
+ (* raiseSys if arg is -1 *)
+ val checkResult: int -> unit
+ val checkReturnResult: int -> int
+ val getErrno: unit -> int
+ (* raises SysErr with ERRNO *)
+ val error: unit -> 'a
+ end
structure SysCall :
sig
val blocker: (unit -> (unit -> unit)) ref
val restartFlag: bool ref
+
+ val syscallErr:
+ {clear: bool, restart: bool} *
+ (unit -> {return: int,
+ post: unit -> 'a,
+ handlers: (syserror * (unit -> 'a)) list}) -> 'a
+
+ (* clear = false, restart = false,
+ * post = fn () => (), handlers = []
+ *)
val simple: (unit -> int) -> unit
+ (* clear = false, restart = true,
+ * post = fn () => (), handlers = []
+ *)
val simpleRestart: (unit -> int) -> unit
+ (* clear = false, restart = false,
+ * post = fn () => return, handlers = []
+ *)
val simpleResult: (unit -> int) -> int
+ (* clear = false, restart = true,
+ * post = fn () => return, handlers = []
+ *)
val simpleResultRestart: (unit -> int) -> int
- val syscall: {restart: bool} * (unit -> int * (unit -> 'a)) -> 'a
+ (* clear = false, restart = false,
+ * handlers = []
+ *)
+ val syscall: (unit -> int * (unit -> 'a)) -> 'a
+ (* clear = false, restart = true,
+ * handlers = []
+ *)
+ val syscallRestart: (unit -> int * (unit -> 'a)) -> 'a
end
end
1.9 +67 -29 mlton/basis-library/posix/error.sml
Index: error.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/error.sml,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- error.sml 30 Apr 2004 01:07:15 -0000 1.8
+++ error.sml 1 May 2004 20:11:39 -0000 1.9
@@ -15,6 +15,8 @@
val toWord = SysWord.fromInt
val fromWord = SysWord.toInt
+ val cleared : syserror = 0
+
fun errorName n =
case List.find (fn (m, _) => n = m) errorNames of
NONE => "<UNKNOWN>"
@@ -35,60 +37,96 @@
end
fun raiseSys n = raise SysErr (errorMsg n, SOME n)
- fun error () = raiseSys (getErrno ())
- 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 = (ignore (checkReturnResult n); ())
+ structure Old =
+ struct
+ fun error () = raiseSys (getErrno ())
+ fun checkReturnResult (n: int) = if n = ~1 then error () else n
+ fun checkResult n = (ignore (checkReturnResult n); ())
+ val getErrno = getErrno
+ end
structure SysCall =
struct
structure Thread = Primitive.Thread
val blocker: (unit -> (unit -> unit)) ref =
- ref (fn () => raise Fail "blocker not installed")
+ ref (fn () => (fn () => ()))
+ (* ref (fn () => raise Fail "blocker not installed") *)
val restartFlag = ref true
-
- val syscall: {restart: bool} *
- (unit -> int * (unit -> 'a)) -> 'a =
- fn ({restart}, f) =>
+
+ val syscallErr: {clear: bool, restart: bool} *
+ (unit -> {return: int,
+ post: unit -> 'a,
+ handlers: (syserror * (unit -> 'a)) list}) -> 'a =
+ fn ({clear, restart}, f) =>
let
- fun call (err: int -> 'a): 'a =
+ fun call (err: {errno: syserror,
+ handlers: (syserror * (unit -> 'a)) list} -> 'a): 'a =
let
val () = Thread.atomicBegin ()
- val (n, post) = f ()
+ val () = if clear then clearErrno () else ()
+ val {return, post, handlers} =
+ f () handle exn => (Thread.atomicEnd (); raise exn)
in
- if n = ~1
+ if return = ~1
then let val e = getErrno ()
- in Thread.atomicEnd () ; err e
+ in Thread.atomicEnd () ; err {errno = e, handlers = handlers}
end
- else (post () before Thread.atomicEnd ())
+ else DynamicWind.wind (post, Thread.atomicEnd)
end
- fun err (e: int): 'a =
- if restart andalso e = intr andalso !restartFlag
- then if Thread.canHandle () = 0
- then call err
- else let val finish = !blocker ()
- in
- DynamicWind.wind
- (fn () => call raiseSys, finish)
- end
- else raiseSys e
+ fun err {default: unit -> 'a,
+ errno: syserror,
+ handlers: (syserror * (unit -> 'a)) list}: 'a =
+ case List.find (fn (e',_) => errno = e') handlers of
+ SOME (_, handler) => handler ()
+ | NONE => default ()
+ fun errBlocked {errno: syserror, handlers: (syserror * (unit -> 'a)) list}: 'a =
+ err {default = fn () => raiseSys errno,
+ errno = errno, handlers = handlers}
+ fun errUnblocked {errno: syserror, handlers: (syserror * (unit -> 'a)) list}: 'a =
+ err {default = fn () =>
+ if restart andalso errno = intr andalso !restartFlag
+ then if Thread.canHandle () = 0
+ then call errUnblocked
+ else let val finish = !blocker ()
+ in
+ DynamicWind.wind
+ (fn () => call errBlocked, finish)
+ end
+ else raiseSys errno,
+ errno = errno, handlers = handlers}
in
- call err
+ call errUnblocked
end
local
val simpleResult' = fn ({restart}, f) =>
- syscall ({restart = restart}, fn () => let val n = f () in (n, fn () => n) end)
+ syscallErr
+ ({clear = false, restart = restart}, fn () =>
+ let val return = f ()
+ in {return = return, post = fn () => return, handlers = []}
+ end)
in
val simpleResultRestart = fn f =>
simpleResult' ({restart = true}, f)
val simpleResult = fn f =>
simpleResult' ({restart = false}, f)
end
-
- val simpleRestart = ignore o simpleResultRestart
+
+ val simpleRestart = ignore o simpleResultRestart
val simple = ignore o simpleResult
+
+ val syscallRestart = fn f =>
+ syscallErr
+ ({clear = false, restart = true}, fn () =>
+ let val (return, post) = f ()
+ in {return = return, post = post, handlers = []}
+ end)
+ val syscall = fn f =>
+ syscallErr
+ ({clear = false, restart = false}, fn () =>
+ let val (return, post) = f ()
+ in {return = return, post = post, handlers = []}
+ end)
end
end
1.16 +102 -64 mlton/basis-library/posix/file-sys.sml
Index: file-sys.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/file-sys.sml,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- file-sys.sml 20 Feb 2004 19:17:32 -0000 1.15
+++ file-sys.sml 1 May 2004 20:11:39 -0000 1.16
@@ -18,14 +18,12 @@
end
structure Error = PosixError
+ structure SysCall = Error.SysCall
structure Prim = PosixPrimitive.FileSys
open Prim
structure Stat = Prim.Stat
structure Flags = BitFlags
- val checkResult = Error.checkResult
- val checkReturnResult = Error.checkReturnResult
-
datatype file_desc = datatype Prim.file_desc
type uid = Prim.uid
type gid = Prim.gid
@@ -52,11 +50,16 @@
fun opendir s =
let
- val d = Prim.opendir (NullString.nullTerm s)
+ val s = NullString.nullTerm s
in
- if Primitive.Pointer.isNull d
- then Error.error ()
- else DS (ref (SOME d))
+ SysCall.syscall
+ (fn () =>
+ let
+ val d = Prim.opendir s
+ in
+ (if Primitive.Pointer.isNull d then ~1 else 0,
+ fn () => DS (ref (SOME d)))
+ end)
end
fun readdir d =
@@ -64,39 +67,53 @@
val d = get d
fun loop () =
let
- val _ = Error.clearErrno ()
- val cs = Prim.readdir d
- in if Primitive.Pointer.isNull cs
- then if Error.getErrno () = 0
- then NONE
- else Error.error ()
- else
- let
- val s = C.CS.toString cs
- in
- if s = "." orelse s = ".."
- then loop ()
- else SOME s
- end
+ 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)]}
+ end)
+ in
+ case res of
+ NONE => NONE
+ | SOME cs =>
+ let
+ val s = C.CS.toString cs
+ in
+ if s = "." orelse s = ".."
+ then loop ()
+ else SOME s
+ end
end
in loop ()
end
fun rewinddir d =
let val d = get d
- in Error.clearErrno ()
- ; Prim.rewinddir d
- ; if Error.getErrno () = 0 then () else Error.error ()
+ in
+ SysCall.syscallErr
+ ({clear = true, restart = false},
+ fn () =>
+ let val () = Prim.rewinddir d
+ in
+ {return = ~1,
+ post = fn () => (),
+ handlers = [(Error.cleared, fn () => ())]}
+ end)
end
fun closedir (DS r) =
case !r of
NONE => ()
- | SOME d => (checkResult (Prim.closedir d); r := NONE)
+ | SOME d => (SysCall.simple (fn () => Prim.closedir d); r := NONE)
end
fun chdir s =
- checkResult (Prim.chdir (NullString.nullTerm s))
+ SysCall.simple (fn () => Prim.chdir (NullString.nullTerm s))
local
val size: int ref = ref 1
@@ -156,23 +173,23 @@
fun createf (pathname, openMode, flags, mode) =
let
+ val pathname = NullString.nullTerm pathname
+ val flags = Flags.flags [openModeToWord openMode,
+ flags,
+ O.creat]
val fd =
- checkReturnResult
- (Prim.openn (NullString.nullTerm pathname,
- Flags.flags [openModeToWord openMode,
- flags,
- O.creat],
- mode))
+ SysCall.simpleResult
+ (fn () => Prim.openn (pathname, flags, mode))
in FD fd
end
fun openf (pathname, openMode, flags) =
let
+ val pathname = NullString.nullTerm pathname
+ val flags = Flags.flags [openModeToWord openMode, flags]
val fd =
- checkReturnResult
- (Prim.openn (NullString.nullTerm pathname,
- Flags.flags [openModeToWord openMode, flags],
- Flags.empty))
+ SysCall.simpleResult
+ (fn () => Prim.openn (pathname, flags, Flags.empty))
in FD fd
end
@@ -181,7 +198,8 @@
val umask = Prim.umask
local
- fun wrap p arg = (checkResult (p arg); ())
+ fun wrap p arg = (SysCall.simple (fn () => p arg); ())
+ fun wrapRestart p arg = (SysCall.simpleRestart (fn () => p arg); ())
fun wrapOldNew p =
wrap (fn {old,new} => p (NullString.nullTerm old,
NullString.nullTerm new))
@@ -197,7 +215,7 @@
val fchmod = wrap (fn (FD n, m) => Prim.fchmod (n, m))
val chown = wrap (fn (s, u, g) => Prim.chown (NullString.nullTerm s, u, g))
val fchown = wrap (fn (FD n, u, g) => Prim.fchown (n, u, g))
- val ftruncate = wrap (fn (FD n, pos) => Prim.ftruncate (n, pos))
+ val ftruncate = wrapRestart (fn (FD n, pos) => Prim.ftruncate (n, pos))
end
local
@@ -205,14 +223,16 @@
val buf = Word8Array.array (size, 0w0)
in
fun readlink (path: string): string =
- let
- val len =
- Prim.readlink (NullString.nullTerm path,
- Word8Array.toPoly buf,
- size)
+ let
+ val path = NullString.nullTerm path
in
- checkResult len
- ; Byte.unpackString (Word8ArraySlice.slice (buf, 0, SOME len))
+ SysCall.syscall
+ (fn () =>
+ let val len = Prim.readlink (path, Word8Array.toPoly buf, size)
+ in
+ (len, fn () =>
+ Byte.unpackString (Word8ArraySlice.slice (buf, 0, SOME len)))
+ end)
end
end
@@ -281,7 +301,7 @@
local
fun make (prim, f) arg =
- (checkResult (prim (f arg))
+ (SysCall.simple (fn () => prim (f arg))
; ST.fromC ())
in
val stat = make (Prim.Stat.stat, NullString.nullTerm)
@@ -297,10 +317,24 @@
| A_EXEC => X_OK
fun access (path: string, mode: access_mode list): bool =
- let val mode = Flags.flags (F_OK :: (map conv_access_mode mode))
- in case Prim.access (NullString.nullTerm path, mode) of
- ~1 => false
- | _ => true
+ let
+ val mode = Flags.flags (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)
end
local
@@ -317,9 +351,14 @@
| SOME {actime = a, modtime = m} => (a, m)
val a = Time.toSeconds a
val m = Time.toSeconds m
- in U.setActime a
- ; U.setModtime m
- ; checkResult (U.utime (NullString.nullTerm f))
+ val f = NullString.nullTerm f
+ in
+ SysCall.syscallRestart
+ (fn () =>
+ (U.setActime a
+ ; U.setModtime m
+ ; (U.utime f, fn () =>
+ ())))
end
end
@@ -330,17 +369,16 @@
| SOME (n, _) => n
fun make prim (f, s) =
- let
- val _ = Error.clearErrno ()
- val n = prim (f, convertProperty s)
- in
- if n < 0
- then if Error.getErrno () = 0
- then NONE
- else Error.error ()
- else SOME (SysWord.fromInt n)
- end
-
+ 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)
in
val pathconf = make (fn (path, s) =>
Prim.pathconf (NullString.nullTerm path, s))
1.16 +49 -36 mlton/basis-library/posix/io.sml
Index: io.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/io.sml,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- io.sml 16 Feb 2004 22:43:22 -0000 1.15
+++ io.sml 1 May 2004 20:11:39 -0000 1.16
@@ -10,8 +10,7 @@
structure Prim = PosixPrimitive.IO
open Prim
structure Error = PosixError
- val checkResult = Error.checkResult
- val checkReturnResult = Error.checkReturnResult
+ structure SysCall = Error.SysCall
structure FS = PosixFileSys
datatype file_desc = datatype Prim.file_desc
@@ -21,17 +20,19 @@
val a: PosixPrimitive.fd array = Array.array (2, 0)
in
fun pipe () =
- (checkResult (Prim.pipe a);
- {infd = FD (Array.sub (a, 0)),
- outfd = FD (Array.sub (a, 1))})
+ SysCall.syscall
+ (fn () =>
+ (Prim.pipe a,
+ fn () => {infd = FD (Array.sub (a, 0)),
+ outfd = FD (Array.sub (a, 1))}))
end
- fun dup (FD fd) = FD (checkReturnResult (Prim.dup fd))
+ fun dup (FD fd) = FD (SysCall.simpleResult (fn () => Prim.dup fd))
fun dup2 {old = FD old, new = FD new} =
- checkResult (Prim.dup2 (old, new))
+ SysCall.simple (fn () => Prim.dup2 (old, new))
- fun close (FD fd) = checkResult (Prim.close fd)
+ fun close (FD fd) = SysCall.simpleRestart (fn () => Prim.close fd)
local
fun make {fromVector, read, toArraySlice, toVectorSlice,
@@ -41,12 +42,15 @@
let
val (buf, i, sz) = ArraySlice.base (toArraySlice sl)
in
- checkReturnResult (read (fd, buf, i, sz))
+ SysCall.simpleResultRestart
+ (fn () => read (fd, buf, i, sz))
end
fun readVec (FD fd, n) =
let
val a = Primitive.Array.array n
- val bytesRead = checkReturnResult (read (fd, a, 0, n))
+ val bytesRead =
+ SysCall.simpleResultRestart
+ (fn () => read (fd, a, 0, n))
in
fromVector
(if n = bytesRead
@@ -58,14 +62,16 @@
let
val (buf, i, sz) = ArraySlice.base (toArraySlice sl)
in
- checkReturnResult (write (fd, buf, i, sz))
+ SysCall.simpleResultRestart
+ (fn () => write (fd, buf, i, sz))
end
val writeVec =
fn (FD fd, sl) =>
let
val (buf, i, sz) = VectorSlice.base (toVectorSlice sl)
in
- checkReturnResult (writeVec (fd, buf, i, sz))
+ SysCall.simpleResultRestart
+ (fn () => writeVec (fd, buf, i, sz))
end
in
{readArr = readArr, readVec = readVec,
@@ -100,27 +106,28 @@
datatype open_mode = datatype PosixFileSys.open_mode
fun dupfd {old = FD old, base = FD base} =
- FD (checkReturnResult (Prim.fcntl3 (old, F_DUPFD, base)))
+ FD (SysCall.simpleResultRestart
+ (fn () => Prim.fcntl3 (old, F_DUPFD, base)))
fun getfd (FD fd) =
- Word.fromInt (checkReturnResult (Prim.fcntl2 (fd, F_GETFD)))
+ Word.fromInt (SysCall.simpleResultRestart
+ (fn () => Prim.fcntl2 (fd, F_GETFD)))
fun setfd (FD fd, flags): unit =
- checkResult (Prim.fcntl3 (fd, F_SETFD, Word.toIntX flags))
+ SysCall.simpleRestart
+ (fn () => Prim.fcntl3 (fd, F_SETFD, Word.toIntX flags))
fun getfl (FD fd): O.flags * open_mode =
- let val n = Prim.fcntl2 (fd, F_GETFL)
- in if n < 0
- then Error.error ()
- else let val w = Word.fromInt n
- val flags = Word.andb (w, Word.notb O_ACCMODE)
- val mode = Word.andb (w, O_ACCMODE)
- in (flags, PosixFileSys.wordToOpenMode mode)
- end
+ let
+ val n = SysCall.simpleResultRestart (fn () => Prim.fcntl2 (fd, F_GETFL))
+ val w = Word.fromInt n
+ val flags = Word.andb (w, Word.notb O_ACCMODE)
+ val mode = Word.andb (w, O_ACCMODE)
+ in (flags, PosixFileSys.wordToOpenMode mode)
end
fun setfl (FD fd, flags: O.flags): unit =
- checkResult (Prim.fcntl3 (fd, F_SETFL, Word.toIntX flags))
+ SysCall.simpleRestart (fn () => Prim.fcntl3 (fd, F_SETFL, Word.toIntX flags))
datatype whence = SEEK_SET | SEEK_CUR | SEEK_END
@@ -139,9 +146,13 @@
else raise Fail "Posix.IO.intToWhence"
fun lseek (FD fd, n: Position.int, w: whence): Position.int =
- Error.checkReturnPosition (Prim.lseek (fd, n, whenceToInt w))
+ SysCall.syscall
+ (fn () =>
+ let val n = Prim.lseek (fd, n, whenceToInt w)
+ in (if n = ~1 then ~1 else 0, fn () => n)
+ end)
- fun fsync (FD fd): unit = checkResult (Prim.fsync fd)
+ fun fsync (FD fd): unit = SysCall.simple (fn () => Prim.fsync fd)
datatype lock_type =
F_RDLCK
@@ -184,16 +195,18 @@
(cmd, usepid)
(FD fd, {ltype, whence, start, len, ...}: FLock.flock)
: FLock.flock =
- (P.setType (lockTypeToInt ltype)
- ; P.setWhence (whenceToInt whence)
- ; P.setStart start
- ; P.setLen len
- ; checkResult (P.fcntl (fd, cmd))
- ; {ltype = intToLockType (P.typ ()),
- whence = intToWhence (P.whence ()),
- start = P.start (),
- len = P.len (),
- pid = if usepid then SOME (P.pid ()) else NONE})
+ SysCall.syscallRestart
+ (fn () =>
+ ((P.setType (lockTypeToInt ltype)
+ ; P.setWhence (whenceToInt whence)
+ ; P.setStart start
+ ; P.setLen len
+ ; P.fcntl (fd, cmd)), fn () =>
+ {ltype = intToLockType (P.typ ()),
+ whence = intToWhence (P.whence ()),
+ start = P.start (),
+ len = P.len (),
+ pid = if usepid then SOME (P.pid ()) else NONE}))
in
val getlk = make (F_GETLK, true)
val setlk = make (F_SETLK, false)
1.10 +42 -33 mlton/basis-library/posix/proc-env.sml
Index: proc-env.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/proc-env.sml,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- proc-env.sml 20 Feb 2004 19:17:32 -0000 1.9
+++ proc-env.sml 1 May 2004 20:11:39 -0000 1.10
@@ -9,6 +9,7 @@
struct
structure Prim = PosixPrimitive.ProcEnv
structure Error = PosixError
+ structure SysCall = Error.SysCall
structure CS = C.CS
type pid = Pid.t
@@ -26,12 +27,12 @@
val getpid = getpid (* No error checking required *)
val getppid = getppid (* No error checking required *)
val getuid = getuid (* No error checking required *)
- val setgid = Error.checkResult o setgid
- val setuid = Error.checkResult o setuid
+ val setgid = fn gid => SysCall.simple (fn () => setgid gid)
+ val setuid = fn uid => SysCall.simple (fn () => setuid uid)
end
- fun setsid () = Pid.fromInt (Error.checkReturnResult
- (Pid.toInt (Prim.setsid ())))
+ fun setsid () =
+ Pid.fromInt (SysCall.simpleResult (Pid.toInt o Prim.setsid))
fun id x = x
val uidToWord = id
@@ -43,10 +44,12 @@
val a: word array = Primitive.Array.array Prim.numgroups
in
fun getgroups () =
- let val n = Prim.getgroups a
- in Error.checkResult n
- ; ArraySlice.toList (ArraySlice.slice (a, 0, SOME n))
- end
+ SysCall.syscall
+ (fn () =>
+ let val n = Prim.getgroups a
+ in (n, fn () =>
+ ArraySlice.toList (ArraySlice.slice (a, 0, SOME n)))
+ end)
end
fun getlogin () =
@@ -61,20 +64,25 @@
val f =
fn NONE => Pid.fromInt 0
| SOME pid => pid
+ val pid = f pid
+ val pgid = f pgid
in
- Error.checkResult (Prim.setpgid (f pid, f pgid))
+ SysCall.simple
+ (fn () => Prim.setpgid (pid, pgid))
end
local
structure Uname = Prim.Uname
in
fun uname () =
- (Error.checkResult (Uname.uname ());
- [("sysname", CS.toString (Uname.sysname ())),
- ("nodename", CS.toString (Uname.nodename ())),
- ("release", CS.toString (Uname.release ())),
- ("version", CS.toString (Uname.version ())),
- ("machine", CS.toString (Uname.machine ()))])
+ SysCall.syscall
+ (fn () =>
+ (Uname.uname (), fn () =>
+ [("sysname", CS.toString (Uname.sysname ())),
+ ("nodename", CS.toString (Uname.nodename ())),
+ ("release", CS.toString (Uname.release ())),
+ ("version", CS.toString (Uname.version ())),
+ ("machine", CS.toString (Uname.machine ()))]))
end
val time = Time.now
@@ -83,10 +91,8 @@
case List.find (fn (_, s') => s = s') Prim.sysconfNames of
NONE => Error.raiseSys Error.inval
| SOME (n, _) =>
- let val res = Prim.sysconf n
- in Error.checkResult res;
- SysWord.fromInt res
- end
+ (SysWord.fromInt o SysCall.simpleResult)
+ (fn () => Prim.sysconf n)
local
structure Tms = Prim.Tms
@@ -100,15 +106,16 @@
ticksPerSec))
in
fun times () =
- let
- val elapsed = Prim.times ()
- in
- {elapsed = cvt elapsed,
- utime = cvt (Tms.utime ()),
- stime = cvt (Tms.stime ()),
- cutime = cvt (Tms.cutime ()),
- cstime = cvt (Tms.cstime ())}
- end
+ SysCall.syscall
+ (fn () =>
+ let val elapsed = Prim.times ()
+ in (0, fn () =>
+ {elapsed = cvt elapsed,
+ utime = cvt (Tms.utime ()),
+ stime = cvt (Tms.stime ()),
+ cutime = cvt (Tms.cutime ()),
+ cstime = cvt (Tms.cstime ())})
+ end)
end
fun environ () = C.CSS.toList Prim.environ
@@ -127,9 +134,11 @@
fun isatty (FD n) = Prim.isatty n
fun ttyname (FD n) =
- let val cs = Prim.ttyname n
- in if Primitive.Pointer.isNull cs
- then Error.error ()
- else CS.toString cs
- end
+ SysCall.syscall
+ (fn () =>
+ let val cs = Prim.ttyname n
+ in
+ (if Primitive.Pointer.isNull cs then ~1 else 0,
+ fn () => CS.toString cs)
+ end)
end
1.21 +44 -18 mlton/basis-library/posix/process.sml
Index: process.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/process.sml,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- process.sml 18 Mar 2004 00:32:44 -0000 1.20
+++ process.sml 1 May 2004 20:11:39 -0000 1.21
@@ -10,6 +10,7 @@
structure Prim = PosixPrimitive.Process
open Prim
structure Error = PosixError
+ structure SysCall = Error.SysCall
type signal = PosixSignal.signal
type pid = Pid.t
@@ -20,14 +21,13 @@
structure MLton = Primitive.MLton
fun fork () =
- let
- val p = Prim.fork ()
- in
- case Pid.toInt p of
- ~1 => Error.error ()
- | 0 => NONE
- | _ => SOME p
- end
+ 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)
val fork =
if let open MLton.Platform.OS in host <> Cygwin end
@@ -82,15 +82,28 @@
val convs = C.CSS.fromList
fun exece (path, args, env): 'a =
- (Error.checkResult (Prim.exece (conv path, convs args, convs env))
- ; raise Fail "Posix.Process.exece")
+ let
+ val path = conv path
+ val args = convs args
+ val env = convs env
+ in
+ (SysCall.simple
+ (fn () => Prim.exece (path, args, env))
+ ; raise Fail "Posix.Process.exece")
+ end
fun exec (path, args): 'a =
exece (path, args, PosixProcEnv.environ ())
fun execp (file, args): 'a =
- (Error.checkResult (Prim.execp (conv file, convs args))
- ; raise Fail "Posix.Process.execp")
+ let
+ val file = conv file
+ val args = convs args
+ in
+ (SysCall.simple
+ (fn () => Prim.execp (file, args))
+ ; raise Fail "Posix.Process.execp")
+ end
datatype waitpid_arg =
W_ANY_CHILD
@@ -130,11 +143,16 @@
| W_CHILD pid => Pid.toInt pid
| W_SAME_GROUP => 0
| W_GROUP pid => ~ (Pid.toInt pid)
- val pid = Prim.waitpid (Pid.fromInt p, status,
- SysWord.toInt (W.flags flags))
- val _ = Error.checkResult (Pid.toInt pid)
+ val flags = W.flags flags
in
- pid
+ SysCall.syscallRestart
+ (fn () =>
+ let
+ val pid = Prim.waitpid (Pid.fromInt p, status,
+ SysWord.toInt flags)
+ in
+ (Pid.toInt pid, fn () => pid)
+ end)
end
fun getStatus () = fromStatus (!status)
in
@@ -177,7 +195,8 @@
| K_SAME_GROUP => ~1
| K_GROUP pid => ~ (Pid.toInt pid)
in
- Error.checkResult (Prim.kill (Pid.fromInt pid, s))
+ SysCall.simple
+ (fn () => Prim.kill (Pid.fromInt pid, s))
end
local
@@ -190,5 +209,12 @@
val sleep = wrap Prim.sleep
end
- fun pause () = Error.checkResult (Prim.pause ())
+ (* FIXME: pause *)
+ fun pause () =
+ SysCall.syscallErr
+ ({clear = false, restart = false},
+ fn () =>
+ {return = Prim.pause (),
+ post = fn () => (),
+ handlers = [(Error.intr, fn () => ())]})
end
1.4 +27 -18 mlton/basis-library/posix/sys-db.sml
Index: sys-db.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/sys-db.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- sys-db.sml 20 Feb 2004 19:17:32 -0000 1.3
+++ sys-db.sml 1 May 2004 20:11:39 -0000 1.4
@@ -10,6 +10,7 @@
structure CS = C.CS
structure Prim = PosixPrimitive.SysDB
structure Error = PosixError
+ structure SysCall = Error.SysCall
type uid = Prim.uid
type gid = Prim.gid
@@ -25,14 +26,15 @@
local
structure C = Prim.Passwd
in
- fun fromC(b: bool): passwd =
- if b
- then {name = CS.toString(C.name()),
- uid = C.uid(),
- gid = C.gid(),
- home = CS.toString(C.dir()),
- shell = CS.toString(C.shell())}
- else Error.error()
+ fun fromC (f: unit -> bool): passwd =
+ SysCall.syscall
+ (fn () =>
+ (if f () then 0 else ~1,
+ fn () => {name = CS.toString(C.name()),
+ uid = C.uid(),
+ gid = C.gid(),
+ home = CS.toString(C.dir()),
+ shell = CS.toString(C.shell())}))
end
val name: passwd -> string = #name
@@ -42,8 +44,11 @@
val shell: passwd -> string = #shell
end
- val getpwnam = Passwd.fromC o Prim.getpwnam o NullString.nullTerm
- val getpwuid = Passwd.fromC o Prim.getpwuid
+ fun getpwnam name =
+ let val name = NullString.nullTerm name
+ in Passwd.fromC (fn () => Prim.getpwnam name)
+ end
+ fun getpwuid uid = Passwd.fromC (fn () => Prim.getpwuid uid)
structure Group =
struct
@@ -53,18 +58,22 @@
structure Group = Prim.Group
- fun fromC(b: bool): group =
- if b
- then {name = CS.toString(Group.name()),
- gid = Group.gid(),
- members = C.CSS.toList(Group.mem())}
- else Error.error()
+ fun fromC (f: unit -> bool): group =
+ SysCall.syscall
+ (fn () =>
+ (if f () then 0 else ~1,
+ fn () => {name = CS.toString(Group.name()),
+ gid = Group.gid(),
+ members = C.CSS.toList(Group.mem())}))
val name: group -> string = #name
val gid: group -> gid = #gid
val members: group -> string list = #members
end
- val getgrnam = Group.fromC o Prim.getgrnam o NullString.nullTerm
- val getgrgid = Group.fromC o Prim.getgrgid
+ fun getgrnam name =
+ let val name = NullString.nullTerm name
+ in Group.fromC (fn () => Prim.getgrnam name)
+ end
+ fun getgrgid gid = Group.fromC (fn () => Prim.getgrgid gid)
end
1.7 +38 -30 mlton/basis-library/posix/tty.sml
Index: tty.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/tty.sml,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- tty.sml 13 Feb 2004 17:05:55 -0000 1.6
+++ tty.sml 1 May 2004 20:11:39 -0000 1.7
@@ -11,6 +11,7 @@
structure Prim = PosixPrimitive.TTY
open Prim
structure Error = PosixError
+ structure SysCall = Error.SysCall
type pid = Pid.t
@@ -120,45 +121,52 @@
open Prim.TC
fun getattr (FD fd) =
- (Error.checkResult (Prim.getattr (fd))
- ; {iflag = Termios.iflag (),
- oflag = Termios.oflag (),
- cflag = Termios.cflag (),
- lflag = Termios.lflag (),
- cc = Cstring.toCharArrayOfLength (Termios.cc (), V.nccs),
- ispeed = Termios.ispeed (),
- ospeed = Termios.ospeed ()})
+ SysCall.syscallRestart
+ (fn () =>
+ (Prim.getattr fd, fn () =>
+ {iflag = Termios.iflag (),
+ oflag = Termios.oflag (),
+ cflag = Termios.cflag (),
+ lflag = Termios.lflag (),
+ cc = Cstring.toCharArrayOfLength (Termios.cc (), V.nccs),
+ ispeed = Termios.ispeed (),
+ ospeed = Termios.ospeed ()}))
fun setattr (FD fd, a, {iflag, oflag, cflag, lflag, cc, ispeed, ospeed}) =
- (Termios.setiflag iflag
- ; Termios.setoflag oflag
- ; Termios.setcflag cflag
- ; Termios.setlflag lflag
- ; 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)))
- end
- ; Error.checkResult (Prim.setattr (fd, a)))
+ SysCall.syscallRestart
+ (fn () =>
+ (Termios.setiflag iflag
+ ; Termios.setoflag oflag
+ ; Termios.setcflag cflag
+ ; Termios.setlflag lflag
+ ; SysCall.simple (fn () => Termios.setospeed ospeed)
+ ; SysCall.simple (fn () => Termios.setispeed ispeed)
+ ; let val cs = Termios.cc ()
+ in Util.naturalForeach
+ (V.nccs, fn i => Cstring.update (cs, i, V.sub (cc, i)))
+ end
+ ; (Prim.setattr (fd, a), fn () => ())))
fun sendbreak (FD fd, n) =
- Error.checkResult (Prim.sendbreak (fd, n))
+ SysCall.simpleRestart (fn () => Prim.sendbreak (fd, n))
- fun drain (FD fd) = Error.checkResult (Prim.drain fd)
+ fun drain (FD fd) =
+ SysCall.simpleRestart (fn () => Prim.drain fd)
- fun flush (FD fd, n) = Error.checkResult (Prim.flush (fd, n))
+ fun flush (FD fd, n) =
+ SysCall.simpleRestart (fn () => Prim.flush (fd, n))
- fun flow (FD fd, n) = Error.checkResult (Prim.flow (fd, n))
+ fun flow (FD fd, n) =
+ SysCall.simpleRestart (fn () => Prim.flow (fd, n))
fun getpgrp (FD fd) =
- let
- val pid = Prim.getpgrp fd
- val _ = Error.checkResult (Pid.toInt pid)
- in
- pid
- end
+ SysCall.syscallRestart
+ (fn () =>
+ let val pid = Prim.getpgrp fd
+ in (Pid.toInt pid, fn () => pid)
+ end)
- fun setpgrp (FD fd, pid) = Error.checkResult (Prim.setpgrp (fd, pid))
+ fun setpgrp (FD fd, pid) =
+ SysCall.simpleRestart (fn () => Prim.setpgrp (fd, pid))
end
end
1.8 +2 -2 mlton/basis-library/system/io.sml
Index: io.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/system/io.sml,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- io.sml 16 Feb 2004 22:43:23 -0000 1.7
+++ io.sml 1 May 2004 20:11:39 -0000 1.8
@@ -122,8 +122,8 @@
then let open PosixError in raiseSys inval end
else Int.fromLarge (Time.toMilliseconds t)
val reventss = Array.array (n, 0w0)
- val _ = Posix.Error.checkResult
- (Prim.poll (fds, eventss, n, timeOut, reventss))
+ val _ = Posix.Error.SysCall.simpleRestart
+ (fn () => Prim.poll (fds, eventss, n, timeOut, reventss))
in
Array.foldri
(fn (i, w, l) =>