basis-library/posix/error.sml

   1 (* Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
   2  *    Jagannathan, and Stephen Weeks.
   3  * Copyright (C) 1997-2000 NEC Research Institute.
   4  *
   5  * MLton is released under a BSD-style license.
   6  * See the file MLton-LICENSE for details.
   7  *)
   8
   9 structure PosixError: POSIX_ERROR_EXTRA =
  10    struct
  11       structure Prim = PrimitiveFFI.Posix.Error
  12       open Prim
  13       structure SysError = PrePosix.SysError
  14
  15       type syserror = SysError.t
  16
  17       val acces = SysError.fromRep EACCES
  18       val addrinuse = SysError.fromRep EADDRINUSE
  19       val addrnotavail = SysError.fromRep EADDRNOTAVAIL
  20       val afnosupport = SysError.fromRep EAFNOSUPPORT
  21       val again = SysError.fromRep EAGAIN
  22       val already = SysError.fromRep EALREADY
  23       val badf = SysError.fromRep EBADF
  24       val badmsg = SysError.fromRep EBADMSG
  25       val busy = SysError.fromRep EBUSY
  26       val canceled = SysError.fromRep ECANCELED
  27       val child = SysError.fromRep ECHILD
  28       val connaborted = SysError.fromRep ECONNABORTED
  29       val connrefused = SysError.fromRep ECONNREFUSED
  30       val connreset = SysError.fromRep ECONNRESET
  31       val deadlk = SysError.fromRep EDEADLK
  32       val destaddrreq = SysError.fromRep EDESTADDRREQ
  33       val dom = SysError.fromRep EDOM
  34       val dquot = SysError.fromRep EDQUOT
  35       val exist = SysError.fromRep EEXIST
  36       val fault = SysError.fromRep EFAULT
  37       val fbig = SysError.fromRep EFBIG
  38       val hostunreach = SysError.fromRep EHOSTUNREACH
  39       val idrm = SysError.fromRep EIDRM
  40       val ilseq = SysError.fromRep EILSEQ
  41       val inprogress = SysError.fromRep EINPROGRESS
  42       val intr = SysError.fromRep EINTR
  43       val inval = SysError.fromRep EINVAL
  44       val io = SysError.fromRep EIO
  45       val isconn = SysError.fromRep EISCONN
  46       val isdir = SysError.fromRep EISDIR
  47       val loop = SysError.fromRep ELOOP
  48       val mfile = SysError.fromRep EMFILE
  49       val mlink = SysError.fromRep EMLINK
  50       val msgsize = SysError.fromRep EMSGSIZE
  51       val multihop = SysError.fromRep EMULTIHOP
  52       val nametoolong = SysError.fromRep ENAMETOOLONG
  53       val netdown = SysError.fromRep ENETDOWN
  54       val netreset = SysError.fromRep ENETRESET
  55       val netunreach = SysError.fromRep ENETUNREACH
  56       val nfile = SysError.fromRep ENFILE
  57       val nobufs = SysError.fromRep ENOBUFS
  58       val nodata = SysError.fromRep ENODATA
  59       val nodev = SysError.fromRep ENODEV
  60       val noent = SysError.fromRep ENOENT
  61       val noexec = SysError.fromRep ENOEXEC
  62       val nolck = SysError.fromRep ENOLCK
  63       val nolink = SysError.fromRep ENOLINK
  64       val nomem = SysError.fromRep ENOMEM
  65       val nomsg = SysError.fromRep ENOMSG
  66       val noprotoopt = SysError.fromRep ENOPROTOOPT
  67       val nospc = SysError.fromRep ENOSPC
  68       val nosr = SysError.fromRep ENOSR
  69       val nostr = SysError.fromRep ENOSTR
  70       val nosys = SysError.fromRep ENOSYS
  71       val notconn = SysError.fromRep ENOTCONN
  72       val notdir = SysError.fromRep ENOTDIR
  73       val notempty = SysError.fromRep ENOTEMPTY
  74       val notsock = SysError.fromRep ENOTSOCK
  75       val notsup = SysError.fromRep ENOTSUP
  76       val notty = SysError.fromRep ENOTTY
  77       val nxio = SysError.fromRep ENXIO
  78       val opnotsupp = SysError.fromRep EOPNOTSUPP
  79       val overflow = SysError.fromRep EOVERFLOW
  80       val perm = SysError.fromRep EPERM
  81       val pipe = SysError.fromRep EPIPE
  82       val proto = SysError.fromRep EPROTO
  83       val protonosupport = SysError.fromRep EPROTONOSUPPORT
  84       val prototype = SysError.fromRep EPROTOTYPE
  85       val range = SysError.fromRep ERANGE
  86       val rofs = SysError.fromRep EROFS
  87       val spipe = SysError.fromRep ESPIPE
  88       val srch = SysError.fromRep ESRCH
  89       val stale = SysError.fromRep ESTALE
  90       val time = SysError.fromRep ETIME
  91       val timedout = SysError.fromRep ETIMEDOUT
  92       val toobig = SysError.fromRep E2BIG
  93       val txtbsy = SysError.fromRep ETXTBSY
  94       val wouldblock = SysError.fromRep EWOULDBLOCK
  95       val xdev = SysError.fromRep EXDEV
  96
  97       local
  98          infixr 5 ::?
  99          fun (n,s) ::? l =
 100             if n = SysError.fromRep ~1
 101                then l
 102                else (n,s) :: l
 103       in
 104          val errorNames =
 105             (acces,"acces") ::?
 106             (addrinuse,"addrinuse") ::?
 107             (addrnotavail,"addrnotavail") ::?
 108             (afnosupport,"afnosupport") ::?
 109             (again,"again") ::?
 110             (already,"already") ::?
 111             (badf,"badf") ::?
 112             (badmsg,"badmsg") ::?
 113             (busy,"busy") ::?
 114             (canceled,"canceled") ::?
 115             (child,"child") ::?
 116             (connaborted,"connaborted") ::?
 117             (connrefused,"connrefused") ::?
 118             (connreset,"connreset") ::?
 119             (deadlk,"deadlk") ::?
 120             (destaddrreq,"destaddrreq") ::?
 121             (dom,"dom") ::?
 122             (dquot,"dquot") ::?
 123             (exist,"exist") ::?
 124             (fault,"fault") ::?
 125             (fbig,"fbig") ::?
 126             (hostunreach,"hostunreach") ::?
 127             (idrm,"idrm") ::?
 128             (ilseq,"ilseq") ::?
 129             (inprogress,"inprogress") ::?
 130             (intr,"intr") ::?
 131             (inval,"inval") ::?
 132             (io,"io") ::?
 133             (isconn,"isconn") ::?
 134             (isdir,"isdir") ::?
 135             (loop,"loop") ::?
 136             (mfile,"mfile") ::?
 137             (mlink,"mlink") ::?
 138             (msgsize,"msgsize") ::?
 139             (multihop,"multihop") ::?
 140             (nametoolong,"nametoolong") ::?
 141             (netdown,"netdown") ::?
 142             (netreset,"netreset") ::?
 143             (netunreach,"netunreach") ::?
 144             (nfile,"nfile") ::?
 145             (nobufs,"nobufs") ::?
 146             (nodata,"nodata") ::?
 147             (nodev,"nodev") ::?
 148             (noent,"noent") ::?
 149             (noexec,"noexec") ::?
 150             (nolck,"nolck") ::?
 151             (nolink,"nolink") ::?
 152             (nomem,"nomem") ::?
 153             (nomsg,"nomsg") ::?
 154             (noprotoopt,"noprotoopt") ::?
 155             (nospc,"nospc") ::?
 156             (nosr,"nosr") ::?
 157             (nostr,"nostr") ::?
 158             (nosys,"nosys") ::?
 159             (notconn,"notconn") ::?
 160             (notdir,"notdir") ::?
 161             (notempty,"notempty") ::?
 162             (notsock,"notsock") ::?
 163             (notsup,"notsup") ::?
 164             (notty,"notty") ::?
 165             (nxio,"nxio") ::?
 166             (opnotsupp,"opnotsupp") ::?
 167             (overflow,"overflow") ::?
 168             (perm,"perm") ::?
 169             (pipe,"pipe") ::?
 170             (proto,"proto") ::?
 171             (protonosupport,"protonosupport") ::?
 172             (prototype,"prototype") ::?
 173             (range,"range") ::?
 174             (rofs,"rofs") ::?
 175             (spipe,"spipe") ::?
 176             (srch,"srch") ::?
 177             (stale,"stale") ::?
 178             (time,"time") ::?
 179             (timedout,"timedout") ::?
 180             (toobig,"toobig") ::?
 181             (txtbsy,"txtbsy") ::?
 182             (wouldblock,"wouldblock") ::?
 183             (xdev,"xdev") ::?
 184             []
 185       end
 186       exception SysErr of string * syserror option
 187
 188       val toWord = C_Int.castToSysWord o SysError.toRep
 189       val fromWord = SysError.fromRep o C_Int.castFromSysWord
 190
 191       val cleared : syserror = SysError.fromRep 0
 192
 193       fun errorName n =
 194          case List.find (fn (m, _) => n = m) errorNames of
 195             NONE => "<UNKNOWN>"
 196           | SOME (_, s) => s
 197
 198       val _ =
 199          General.addExnMessager
 200          (fn e =>
 201           case e of
 202              SysErr (s, eo) =>
 203                 SOME (concat ["SysErr: ", s,
 204                               case eo of
 205                                  NONE => ""
 206                                | SOME e => concat [" [", errorName e, "]"]])
 207            | _ => NONE)
 208
 209       fun syserror s =
 210          case List.find (fn (_, s') => s = s') errorNames of
 211             NONE => NONE
 212           | SOME (n, _) => SOME n
 213
 214       fun errorMsg (n: syserror) =
 215          let
 216             val cs = strError (SysError.toRep n)
 217          in
 218             if Primitive.MLton.Pointer.isNull
 219                (Primitive.MLton.Pointer.fromWord cs)
 220                then "Unknown error"
 221                else CUtil.C_String.toString cs
 222          end
 223
 224       fun raiseSys n = raise SysErr (errorMsg n, SOME n)
 225       fun raiseSysWithMsg (n, msg) = raise SysErr ((errorMsg n) ^ ": " ^ msg, SOME n)
 226
 227       structure SysCall =
 228          struct
 229             structure Thread = Primitive.MLton.Thread
 230
 231             val blocker: (unit -> (unit -> unit)) ref =
 232                ref (fn () => (fn () => ()))
 233                (* ref (fn () => raise Fail "blocker not installed") *)
 234             val restartFlag = ref true
 235
 236             val syscallErr: {clear: bool, restart: bool, errVal: ''a} *
 237                             (unit -> {return: ''a C_Errno.t,
 238                                       post: ''a -> 'b,
 239                                       handlers: (syserror * (unit -> 'b)) list}) -> 'b =
 240                fn ({clear, restart, errVal}, f) =>
 241                let
 242                   fun call (err: {errno: syserror,
 243                                   handlers: (syserror * (unit -> 'b)) list} -> 'b): 'b =
 244                      let
 245                         val () = Thread.atomicBegin ()
 246                         val () = if clear then clearErrno () else ()
 247                         val {return, post, handlers} =
 248                            f () handle exn => (Thread.atomicEnd (); raise exn)
 249                         val return = C_Errno.check return
 250                      in
 251                         if errVal = return
 252                            then
 253                               (* Must getErrno () in the critical section. *)
 254                               let
 255                                  val e = SysError.fromRep (getErrno ())
 256                                  val () = Thread.atomicEnd ()
 257                               in
 258                                  err {errno = e, handlers = handlers}
 259                               end
 260                            else DynamicWind.wind (fn () => post return , Thread.atomicEnd)
 261                      end
 262                   fun err {default: unit -> 'b,
 263                            errno: syserror,
 264                            handlers: (syserror * (unit -> 'b)) list}: 'b =
 265                      case List.find (fn (e',_) => errno = e') handlers of
 266                         NONE => default ()
 267                       | SOME (_, handler) => handler ()
 268                   fun errBlocked {errno: syserror,
 269                                   handlers: (syserror * (unit -> 'b)) list}: 'b =
 270                      err {default = fn () => raiseSys errno,
 271                           errno = errno, handlers = handlers}
 272                   fun errUnblocked
 273                      {errno: syserror,
 274                       handlers: (syserror * (unit -> 'b)) list}: 'b =
 275                      err {default = fn () =>
 276                           if restart andalso errno = intr andalso !restartFlag
 277                              then if Thread.atomicState () = 0w0
 278                                      then call errUnblocked
 279                                      else let val finish = !blocker ()
 280                                           in
 281                                              DynamicWind.wind
 282                                              (fn () => call errBlocked, finish)
 283                                           end
 284                              else raiseSys errno,
 285                           errno = errno, handlers = handlers}
 286                in
 287                   call errUnblocked
 288                end
 289
 290             local
 291                val simpleResultAux = fn ({restart, errVal}, f) =>
 292                   syscallErr
 293                   ({clear = false, restart = restart, errVal = errVal}, fn () =>
 294                    let val return = f ()
 295                    in {return = return,
 296                        post = fn ret => ret,
 297                        handlers = []}
 298                    end)
 299             in
 300                val simpleResultRestart = fn f =>
 301                   simpleResultAux ({restart = true, errVal = C_Int.fromInt ~1}, f)
 302                val simpleResult = fn f =>
 303                   simpleResultAux ({restart = false, errVal = C_Int.fromInt ~1}, f)
 304
 305                val simpleResultRestart' = fn ({errVal}, f) =>
 306                   simpleResultAux ({restart = true, errVal = errVal}, f)
 307                val simpleResult' = fn ({errVal}, f) =>
 308                   simpleResultAux ({restart = false, errVal = errVal}, f)
 309             end
 310
 311             val simpleRestart = ignore o simpleResultRestart
 312             val simple = ignore o simpleResult
 313
 314             val simpleRestart' = fn ({errVal}, f) =>
 315                ignore (simpleResultRestart' ({errVal = errVal}, f))
 316             val simple' = fn ({errVal}, f) =>
 317                ignore (simpleResult' ({errVal = errVal}, f))
 318
 319             val syscallRestart' = fn ({errVal}, f) =>
 320                syscallErr
 321                ({clear = false, restart = true, errVal = errVal}, fn () =>
 322                 let val (return, post) = f ()
 323                 in {return = return, post = post, handlers = []}
 324                 end)
 325             val syscall' = fn ({errVal}, f) =>
 326                syscallErr
 327                ({clear = false, restart = false, errVal = errVal}, fn () =>
 328                 let val (return, post) = f ()
 329                 in {return = return, post = post, handlers = []}
 330                 end)
 331             val syscallRestart = fn f =>
 332                syscallRestart' ({errVal = C_Int.fromInt ~1}, f)
 333             val syscall = fn f =>
 334                syscall' ({errVal = C_Int.fromInt ~1}, f)
 335          end
 336    end