From 3db2b1ac1449decbce23353d210033c740dfd888 Mon Sep 17 00:00:00 2001 From: Richard M Kreuter Date: Sun, 30 Dec 2007 05:32:29 +0000 Subject: [PATCH] 1.0.13.2: Removing UNIX-NAMESTRING, part 3 (sort of) * Add condition classes to SB-POSIX that are subclasses of FILE-ERROR, to give more precise information than vanilla FILE-ERRORs after users load SB-POSIX. * Add code to sb-grovel in support of same. --- contrib/sb-grovel/def-to-lisp.lisp | 4 +- contrib/sb-posix/constants.lisp | 246 ++++++++++++++++++------------------- contrib/sb-posix/interface.lisp | 73 ++++++++++- version.lisp-expr | 2 +- 4 files changed, 198 insertions(+), 127 deletions(-) diff --git a/contrib/sb-grovel/def-to-lisp.lisp b/contrib/sb-grovel/def-to-lisp.lisp index aa13f2e71..7549b86e2 100644 --- a/contrib/sb-grovel/def-to-lisp.lisp +++ b/contrib/sb-grovel/def-to-lisp.lisp @@ -112,10 +112,12 @@ code: (dolist (def definitions) (destructuring-bind (type lispname cname &optional doc export) def (case type - (:integer + ((:integer :errno) (as-c "#ifdef" cname) (printf "(cl:defconstant ~A %d \"~A\")" lispname doc cname) + (when (eql type :errno) + (printf "(cl:setf (get '~A 'errno) t)" lispname)) (as-c "#else") (printf "(sb-int:style-warn \"Couldn't grovel for ~A (unknown to the C compiler).\")" cname) (as-c "#endif")) diff --git a/contrib/sb-posix/constants.lisp b/contrib/sb-posix/constants.lisp index 5b4f65b4f..0243a850f 100644 --- a/contrib/sb-posix/constants.lisp +++ b/contrib/sb-posix/constants.lisp @@ -85,129 +85,129 @@ (:integer SIGRTMAX "SIGRTMAX" #+sb-doc "Largest real-time signal number." t) ;; error numbers - (:integer eperm "EPERM" nil t) - (:integer enoent "ENOENT" nil t) - (:integer esrch "ESRCH" nil t) - (:integer eintr "EINTR" nil t) - (:integer eio "EIO" nil t) - (:integer enxio "ENXIO" nil t) - (:integer e2big "E2BIG" nil t) - (:integer enoexec "ENOEXEC" nil t) - (:integer ebadf "EBADF" nil t) - (:integer echild "ECHILD" nil t) - (:integer eagain "EAGAIN" nil t) - (:integer enomem "ENOMEM" nil t) - (:integer eacces "EACCES" nil t) - (:integer efault "EFAULT" nil t) - (:integer enotblk "ENOTBLK" nil t) - (:integer ebusy "EBUSY" nil t) - (:integer eexist "EEXIST" nil t) - (:integer exdev "EXDEV" nil t) - (:integer enodev "ENODEV" nil t) - (:integer enotdir "ENOTDIR" nil t) - (:integer eisdir "EISDIR" nil t) - (:integer einval "EINVAL" nil t) - (:integer enfile "ENFILE" nil t) - (:integer emfile "EMFILE" nil t) - (:integer enotty "ENOTTY" nil t) - (:integer etxtbsy "ETXTBSY" nil t) - (:integer efbig "EFBIG" nil t) - (:integer enospc "ENOSPC" nil t) - (:integer espipe "ESPIPE" nil t) - (:integer erofs "EROFS" nil t) - (:integer emlink "EMLINK" nil t) - (:integer epipe "EPIPE" nil t) - (:integer edom "EDOM" nil t) - (:integer erange "ERANGE" nil t) - (:integer edeadlk "EDEADLK" nil t) - (:integer enametoolong "ENAMETOOLONG" nil t) - (:integer enolck "ENOLCK" nil t) - (:integer enosys "ENOSYS" nil t) - (:integer enotempty "ENOTEMPTY" nil t) - (:integer eloop "ELOOP" nil t) - (:integer ewouldblock "EWOULDBLOCK" nil t) - (:integer enomsg "ENOMSG" nil t) - (:integer eidrm "EIDRM" nil t) - (:integer echrng "ECHRNG" nil t) - (:integer el2nsync "EL2NSYNC" nil t) - (:integer el3hlt "EL3HLT" nil t) - (:integer el3rst "EL3RST" nil t) - (:integer elnrng "ELNRNG" nil t) - (:integer eunatch "EUNATCH" nil t) - (:integer enocsi "ENOCSI" nil t) - (:integer el2hlt "EL2HLT" nil t) - (:integer ebade "EBADE" nil t) - (:integer ebadr "EBADR" nil t) - (:integer exfull "EXFULL" nil t) - (:integer enoano "ENOANO" nil t) - (:integer ebadrqc "EBADRQC" nil t) - (:integer ebadslt "EBADSLT" nil t) - (:integer edeadlock "EDEADLOCK" nil t) - (:integer ebfont "EBFONT" nil t) - (:integer enostr "ENOSTR" nil t) - (:integer enodata "ENODATA" nil t) - (:integer etime "ETIME" nil t) - (:integer enosr "ENOSR" nil t) - (:integer enonet "ENONET" nil t) - (:integer enopkg "ENOPKG" nil t) - (:integer eremote "EREMOTE" nil t) - (:integer enolink "ENOLINK" nil t) - (:integer eadv "EADV" nil t) - (:integer esrmnt "ESRMNT" nil t) - (:integer ecomm "ECOMM" nil t) - (:integer eproto "EPROTO" nil t) - (:integer emultihop "EMULTIHOP" nil t) - (:integer edotdot "EDOTDOT" nil t) - (:integer ebadmsg "EBADMSG" nil t) - (:integer eoverflow "EOVERFLOW" nil t) - (:integer enotuniq "ENOTUNIQ" nil t) - (:integer ebadfd "EBADFD" nil t) - (:integer eremchg "EREMCHG" nil t) - (:integer elibacc "ELIBACC" nil t) - (:integer elibbad "ELIBBAD" nil t) - (:integer elibscn "ELIBSCN" nil t) - (:integer elibmax "ELIBMAX" nil t) - (:integer elibexec "ELIBEXEC" nil t) - (:integer eilseq "EILSEQ" nil t) - (:integer erestart "ERESTART" nil t) - (:integer estrpipe "ESTRPIPE" nil t) - (:integer eusers "EUSERS" nil t) - (:integer enotsock "ENOTSOCK" nil t) - (:integer edestaddrreq "EDESTADDRREQ" nil t) - (:integer emsgsize "EMSGSIZE" nil t) - (:integer eprototype "EPROTOTYPE" nil t) - (:integer enoprotoopt "ENOPROTOOPT" nil t) - (:integer eprotonosupport "EPROTONOSUPPORT" nil t) - (:integer esocktnosupport "ESOCKTNOSUPPORT" nil t) - (:integer eopnotsupp "EOPNOTSUPP" nil t) - (:integer epfnosupport "EPFNOSUPPORT" nil t) - (:integer eafnosupport "EAFNOSUPPORT" nil t) - (:integer eaddrinuse "EADDRINUSE" nil t) - (:integer eaddrnotavail "EADDRNOTAVAIL" nil t) - (:integer enetdown "ENETDOWN" nil t) - (:integer enetunreach "ENETUNREACH" nil t) - (:integer enetreset "ENETRESET" nil t) - (:integer econnaborted "ECONNABORTED" nil t) - (:integer econnreset "ECONNRESET" nil t) - (:integer enobufs "ENOBUFS" nil t) - (:integer eisconn "EISCONN" nil t) - (:integer enotconn "ENOTCONN" nil t) - (:integer eshutdown "ESHUTDOWN" nil t) - (:integer etoomanyrefs "ETOOMANYREFS" nil t) - (:integer etimedout "ETIMEDOUT" nil t) - (:integer econnrefused "ECONNREFUSED" nil t) - (:integer ehostdown "EHOSTDOWN" nil t) - (:integer ehostunreach "EHOSTUNREACH" nil t) - (:integer ealready "EALREADY" nil t) - (:integer einprogress "EINPROGRESS" nil t) - (:integer estale "ESTALE" nil t) - (:integer euclean "EUCLEAN" nil t) - (:integer enotnam "ENOTNAM" nil t) - (:integer enavail "ENAVAIL" nil t) - (:integer eremoteio "EREMOTEIO" nil t) - (:integer edquot "EDQUOT" nil t) - (:integer enomedium "ENOMEDIUM" nil t) - (:integer emediumtype "EMEDIUMTYPE" nil t) + (:errno eperm "EPERM" nil t) + (:errno enoent "ENOENT" nil t) + (:errno esrch "ESRCH" nil t) + (:errno eintr "EINTR" nil t) + (:errno eio "EIO" nil t) + (:errno enxio "ENXIO" nil t) + (:errno e2big "E2BIG" nil t) + (:errno enoexec "ENOEXEC" nil t) + (:errno ebadf "EBADF" nil t) + (:errno echild "ECHILD" nil t) + (:errno eagain "EAGAIN" nil t) + (:errno enomem "ENOMEM" nil t) + (:errno eacces "EACCES" nil t) + (:errno efault "EFAULT" nil t) + (:errno enotblk "ENOTBLK" nil t) + (:errno ebusy "EBUSY" nil t) + (:errno eexist "EEXIST" nil t) + (:errno exdev "EXDEV" nil t) + (:errno enodev "ENODEV" nil t) + (:errno enotdir "ENOTDIR" nil t) + (:errno eisdir "EISDIR" nil t) + (:errno einval "EINVAL" nil t) + (:errno enfile "ENFILE" nil t) + (:errno emfile "EMFILE" nil t) + (:errno enotty "ENOTTY" nil t) + (:errno etxtbsy "ETXTBSY" nil t) + (:errno efbig "EFBIG" nil t) + (:errno enospc "ENOSPC" nil t) + (:errno espipe "ESPIPE" nil t) + (:errno erofs "EROFS" nil t) + (:errno emlink "EMLINK" nil t) + (:errno epipe "EPIPE" nil t) + (:errno edom "EDOM" nil t) + (:errno erange "ERANGE" nil t) + (:errno edeadlk "EDEADLK" nil t) + (:errno enametoolong "ENAMETOOLONG" nil t) + (:errno enolck "ENOLCK" nil t) + (:errno enosys "ENOSYS" nil t) + (:errno enotempty "ENOTEMPTY" nil t) + (:errno eloop "ELOOP" nil t) + (:errno ewouldblock "EWOULDBLOCK" nil t) + (:errno enomsg "ENOMSG" nil t) + (:errno eidrm "EIDRM" nil t) + (:errno echrng "ECHRNG" nil t) + (:errno el2nsync "EL2NSYNC" nil t) + (:errno el3hlt "EL3HLT" nil t) + (:errno el3rst "EL3RST" nil t) + (:errno elnrng "ELNRNG" nil t) + (:errno eunatch "EUNATCH" nil t) + (:errno enocsi "ENOCSI" nil t) + (:errno el2hlt "EL2HLT" nil t) + (:errno ebade "EBADE" nil t) + (:errno ebadr "EBADR" nil t) + (:errno exfull "EXFULL" nil t) + (:errno enoano "ENOANO" nil t) + (:errno ebadrqc "EBADRQC" nil t) + (:errno ebadslt "EBADSLT" nil t) + (:errno edeadlock "EDEADLOCK" nil t) + (:errno ebfont "EBFONT" nil t) + (:errno enostr "ENOSTR" nil t) + (:errno enodata "ENODATA" nil t) + (:errno etime "ETIME" nil t) + (:errno enosr "ENOSR" nil t) + (:errno enonet "ENONET" nil t) + (:errno enopkg "ENOPKG" nil t) + (:errno eremote "EREMOTE" nil t) + (:errno enolink "ENOLINK" nil t) + (:errno eadv "EADV" nil t) + (:errno esrmnt "ESRMNT" nil t) + (:errno ecomm "ECOMM" nil t) + (:errno eproto "EPROTO" nil t) + (:errno emultihop "EMULTIHOP" nil t) + (:errno edotdot "EDOTDOT" nil t) + (:errno ebadmsg "EBADMSG" nil t) + (:errno eoverflow "EOVERFLOW" nil t) + (:errno enotuniq "ENOTUNIQ" nil t) + (:errno ebadfd "EBADFD" nil t) + (:errno eremchg "EREMCHG" nil t) + (:errno elibacc "ELIBACC" nil t) + (:errno elibbad "ELIBBAD" nil t) + (:errno elibscn "ELIBSCN" nil t) + (:errno elibmax "ELIBMAX" nil t) + (:errno elibexec "ELIBEXEC" nil t) + (:errno eilseq "EILSEQ" nil t) + (:errno erestart "ERESTART" nil t) + (:errno estrpipe "ESTRPIPE" nil t) + (:errno eusers "EUSERS" nil t) + (:errno enotsock "ENOTSOCK" nil t) + (:errno edestaddrreq "EDESTADDRREQ" nil t) + (:errno emsgsize "EMSGSIZE" nil t) + (:errno eprototype "EPROTOTYPE" nil t) + (:errno enoprotoopt "ENOPROTOOPT" nil t) + (:errno eprotonosupport "EPROTONOSUPPORT" nil t) + (:errno esocktnosupport "ESOCKTNOSUPPORT" nil t) + (:errno eopnotsupp "EOPNOTSUPP" nil t) + (:errno epfnosupport "EPFNOSUPPORT" nil t) + (:errno eafnosupport "EAFNOSUPPORT" nil t) + (:errno eaddrinuse "EADDRINUSE" nil t) + (:errno eaddrnotavail "EADDRNOTAVAIL" nil t) + (:errno enetdown "ENETDOWN" nil t) + (:errno enetunreach "ENETUNREACH" nil t) + (:errno enetreset "ENETRESET" nil t) + (:errno econnaborted "ECONNABORTED" nil t) + (:errno econnreset "ECONNRESET" nil t) + (:errno enobufs "ENOBUFS" nil t) + (:errno eisconn "EISCONN" nil t) + (:errno enotconn "ENOTCONN" nil t) + (:errno eshutdown "ESHUTDOWN" nil t) + (:errno etoomanyrefs "ETOOMANYREFS" nil t) + (:errno etimedout "ETIMEDOUT" nil t) + (:errno econnrefused "ECONNREFUSED" nil t) + (:errno ehostdown "EHOSTDOWN" nil t) + (:errno ehostunreach "EHOSTUNREACH" nil t) + (:errno ealready "EALREADY" nil t) + (:errno einprogress "EINPROGRESS" nil t) + (:errno estale "ESTALE" nil t) + (:errno euclean "EUCLEAN" nil t) + (:errno enotnam "ENOTNAM" nil t) + (:errno enavail "ENAVAIL" nil t) + (:errno eremoteio "EREMOTEIO" nil t) + (:errno edquot "EDQUOT" nil t) + (:errno enomedium "ENOMEDIUM" nil t) + (:errno emediumtype "EMEDIUMTYPE" nil t) ;; wait (:integer wnohang "WNOHANG") diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp index cef0c7155..541c3c96f 100644 --- a/contrib/sb-posix/interface.lisp +++ b/contrib/sb-posix/interface.lisp @@ -63,9 +63,78 @@ (format s "System call error ~A (~A)" errno (sb-int:strerror errno)))))) -(defun syscall-error () - (error 'sb-posix:syscall-error :errno (get-errno))) +(defvar *errno-table* + (let ((errno-max 0) + list) + (do-symbols (symbol (find-package "SB-POSIX")) + (when (get symbol 'errno) + (let ((errno (symbol-value symbol))) + (setf errno-max (max errno errno-max)) + (push (cons errno + (eval `(define-condition ,symbol (syscall-error) ()))) + list)))) + (let ((table (make-array (1+ errno-max)))) + (mapc #'(lambda (cons) (setf (elt table (car cons)) (cdr cons))) list) + table))) +(defun syscall-error () + (let ((errno (get-errno))) + (error (elt *errno-table* errno) :errno errno))) + +;; Note that we inherit from SIMPLE-FILE-ERROR first, to get its +;; error reporting, rather than SYSCALL-ERROR's. +(define-condition file-syscall-error + (sb-impl::simple-file-error syscall-error) + ()) + +(defvar *file-errno-table* + (let ((array (copy-seq *errno-table*))) + (map-into array + (lambda (condition-class-name) + (if (symbolp condition-class-name) + (let ((file-condition-name + (read-from-string + (format nil "FILE-~A" condition-class-name)))) + ;; Should condition class names like FILE-ENOENT + ;; and FILE-ENOTDIR be exported? I want to say + ;; "no", since we already export ENOENT, ENOTDIR + ;; et al, and so the user can write handlers + ;; such as + ;; + ;; (handler-bind ((sb-posix:enoent ...) + ;; (sb-posix:enotdir ...) + ;; (file-error ...)) + ;; ...) + ;; + ;; which will do the right thing for all our + ;; FILE-SYSCALL-ERRORs, without exposing this + ;; implementation detail. (Recall that some + ;; FILE-ERRORs don't strictly have to do with + ;; the file system, e.g., supplying a wild + ;; pathname to some functions.) But if the + ;; prevailing opinion is otherwise, uncomment + ;; the following. + #| (export file-condition-name) |# + (eval `(define-condition ,file-condition-name + (,condition-class-name file-syscall-error) + ()))) + condition-class-name)) + array) + array)) + +;; Note: do we have to declare SIMPLE-FILE-PERROR notinline in +;; fd-stream.lisp? +(sb-ext:without-package-locks + (defun sb-impl::simple-file-perror (note-format pathname errno) + (error (elt *file-errno-table* errno) + :pathname pathname + :errno errno + :format-control "~@<~?: ~2I~_~A~:>" + :format-arguments + (list note-format (list pathname) (sb-int:strerror errno))))) + +;; Note: it might prove convenient to develop a parallel set of +;; condition classes for STREAM-ERRORs, too. (declaim (inline never-fails)) (defun never-fails (&rest args) (declare (ignore args)) diff --git a/version.lisp-expr b/version.lisp-expr index 10840873c..8b0291ab5 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.13.1" +"1.0.13.2" -- 2.11.4.GIT