[MLton-commit] r4421
Matthew Fluet
MLton@mlton.org
Tue, 25 Apr 2006 15:30:25 -0700
Make 'a C_Errno.t an opaque type, requires check to extract value
----------------------------------------------------------------------
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/build/sources.mlb
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/amd64-linux/c-types.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/errno.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/misc/c-types.m32.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/misc/c-types.m64.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/misc/c-types.weird.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/io/io.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/io/prim-io.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/posix/error.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/posix/error.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/primitive.mlb
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/system/date.sml
U mlton/branches/on-20050822-x86_64-branch/runtime/gen/gen-types.c
----------------------------------------------------------------------
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/build/sources.mlb
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/build/sources.mlb 2006-04-25 21:02:35 UTC (rev 4420)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/build/sources.mlb 2006-04-25 22:30:23 UTC (rev 4421)
@@ -197,20 +197,19 @@
../util/cleaner.sml
../system/pre-os.sml
+
+ ../posix/error.sig
+ ../posix/error.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/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
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/amd64-linux/c-types.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/amd64-linux/c-types.sml 2006-04-25 21:02:35 UTC (rev 4420)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/amd64-linux/c-types.sml 2006-04-25 22:30:23 UTC (rev 4421)
@@ -125,4 +125,3 @@
functor C_MPLimb_ChooseWordN (A: CHOOSE_WORDN_ARG) = ChooseWordN_Word32 (A)
-structure C_Errno = struct type 'a t = 'a end
Added: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/errno.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/errno.sml 2006-04-25 21:02:35 UTC (rev 4420)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/errno.sml 2006-04-25 22:30:23 UTC (rev 4421)
@@ -0,0 +1,16 @@
+(* Copyright (C) 1999-2006 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 C_Errno :>
+ sig
+ type 'a t
+ val check: 'a t -> 'a
+ end =
+ struct
+ type 'a t = 'a
+ val check = fn x => x
+ end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/misc/c-types.m32.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/misc/c-types.m32.sml 2006-04-25 21:02:35 UTC (rev 4420)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/misc/c-types.m32.sml 2006-04-25 22:30:23 UTC (rev 4421)
@@ -125,4 +125,3 @@
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.refactor/config/c/misc/c-types.m64.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/misc/c-types.m64.sml 2006-04-25 21:02:35 UTC (rev 4420)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/misc/c-types.m64.sml 2006-04-25 22:30:23 UTC (rev 4421)
@@ -125,4 +125,3 @@
functor C_MPLimb_ChooseWordN (A: CHOOSE_WORDN_ARG) = ChooseWordN_Word64 (A)
-structure C_Errno = struct type 'a t = 'a end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/misc/c-types.weird.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/misc/c-types.weird.sml 2006-04-25 21:02:35 UTC (rev 4420)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/misc/c-types.weird.sml 2006-04-25 22:30:23 UTC (rev 4421)
@@ -125,4 +125,3 @@
functor C_MPLimb_ChooseWordN (A: CHOOSE_WORDN_ARG) = ChooseWordN_Word16 (A)
-structure C_Errno = struct type 'a t = 'a end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/io/io.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/io/io.sig 2006-04-25 21:02:35 UTC (rev 4420)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/io/io.sig 2006-04-25 22:30:23 UTC (rev 4421)
@@ -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.refactor/io/prim-io.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/io/prim-io.sig 2006-04-25 21:02:35 UTC (rev 4420)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/io/prim-io.sig 2006-04-25 22:30:23 UTC (rev 4421)
@@ -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.refactor/posix/error.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/posix/error.sig 2006-04-25 21:02:35 UTC (rev 4420)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/posix/error.sig 2006-04-25 22:30:23 UTC (rev 4421)
@@ -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.refactor/posix/error.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/posix/error.sml 2006-04-25 21:02:35 UTC (rev 4420)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/posix/error.sml 2006-04-25 22:30:23 UTC (rev 4421)
@@ -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,42 @@
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 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 +248,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 +279,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.refactor/primitive/primitive.mlb
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/primitive.mlb 2006-04-25 21:02:35 UTC (rev 4420)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/primitive.mlb 2006-04-25 22:30:23 UTC (rev 4421)
@@ -45,6 +45,7 @@
../config/objptr/$(OBJPTR_REP)
../config/header/$(HEADER_WORD)
../config/seq/$(SEQ_INDEX)
+ ../config/c/errno.sml
../config/c/misc/$(CTYPES)
end end
prim-seq.sml
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/system/date.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/system/date.sml 2006-04-25 21:02:35 UTC (rev 4420)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/system/date.sml 2006-04-25 22:30:23 UTC (rev 4421)
@@ -98,7 +98,7 @@
; Tm.setYDay tm_yday
; Tm.setYear tm_year)
- fun mktime_ (t: tmoz): C_Time.t = (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 = C_Double.round (Prim.localOffset ())
Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gen/gen-types.c
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gen/gen-types.c 2006-04-25 21:02:35 UTC (rev 4420)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gen/gen-types.c 2006-04-25 22:30:23 UTC (rev 4421)
@@ -267,7 +267,6 @@
static char* cTypesSMLSuffix[] = {
"",
- "structure C_Errno = struct type 'a t = 'a end",
NULL
};