From: Nikodemus Siivola Date: Fri, 27 May 2011 10:55:11 +0000 (+0000) Subject: 1.0.48.27: sb-posix: make syscall errors report the failing function X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=ffb003f5648f1abe64561c8a426878774e10a21b;p=sbcl.git 1.0.48.27: sb-posix: make syscall errors report the failing function Also add a declaim for the SYSCALL-ERROR ftype so the failing function will not be tail-merged is SYSCALL-ERROR appears in tail position. --- diff --git a/NEWS b/NEWS index bdd10db..aaabe97 100644 --- a/NEWS +++ b/NEWS @@ -17,7 +17,9 @@ changes relative to sbcl-1.0.48: spines, not their argumets. While portable code should not rely on this, particularly in combination with inlining, it should make dynamic-extent easier and safer to use. - * enhancement: SB-POSIX exports WNOHANG and WUNTRACED. + * enhancement: SB-POSIX improvements: + ** WNOHANG and WUNTRACED are exported. + ** SYSCALL-ERROR now also provides the name of the failing system call. * optimization: using a &REST argument only in APPLY or VALUES-LIST calls allows the compiler to automatically elide rest-list allocation so long as the call sites are in functions that the compiler knows cannot escape. diff --git a/contrib/sb-posix/defpackage.lisp b/contrib/sb-posix/defpackage.lisp index ecdd292..23c5cce 100644 --- a/contrib/sb-posix/defpackage.lisp +++ b/contrib/sb-posix/defpackage.lisp @@ -1,6 +1,6 @@ (defpackage :sb-posix (:use #:sb-alien #:cl) (:shadow close open ftruncate truncate time read write) - (:export #:syscall-error #:syscall-errno + (:export #:syscall-error #:syscall-errno #:syscall-name ;; types and type conversion #:file-descriptor-designator diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp index 3ac862e..732922e 100644 --- a/contrib/sb-posix/interface.lisp +++ b/contrib/sb-posix/interface.lisp @@ -61,14 +61,20 @@ (find-class ',name)))) (define-condition sb-posix:syscall-error (error) - ((errno :initarg :errno :reader sb-posix:syscall-errno)) + ((errno :initarg :errno :reader sb-posix:syscall-errno) + (name :initarg :name :initform nil :reader sb-posix:syscall-name)) (:report (lambda (c s) (let ((errno (sb-posix:syscall-errno c))) - (format s "System call error ~A (~A)" - errno (sb-int:strerror errno)))))) + (format s "Error in ~S: ~A (~A)" + (sb-posix:syscall-name c) + (sb-int:strerror errno) + errno))))) -(defun syscall-error () - (error 'sb-posix:syscall-error :errno (get-errno))) +(declaim (ftype (function (symbol) nil) syscall-error)) +(defun syscall-error (name) + (error 'sb-posix:syscall-error + :name name + :errno (get-errno))) (defun unsupported-error (lisp-name c-name) (error "~S is unsupported by SBCL on this platform due to lack of ~A()." @@ -195,7 +201,7 @@ (function ,result-type system-area-pointer)) (sb-alien::vector-sap arg)))) (when (,errorp result) - (syscall-error)) + (syscall-error ',lisp-name)) ;; FIXME: We'd rather return pathnames, but other ;; SB-POSIX functions like this return strings... (let ((pathname (sb-ext:octets-to-string @@ -357,7 +363,7 @@ not supported." (with-growing-c-string (buf size) (let ((count (%readlink (filename pathspec) buf size))) (cond ((minusp count) - (syscall-error)) + (syscall-error 'readlink)) ((< 0 count size) (buf count)))))))) @@ -375,7 +381,7 @@ not supported." (cond (result (buf)) ((/= (get-errno) sb-posix:erange) - (syscall-error)))))))) + (syscall-error 'getcwd)))))))) #-win32 (progn @@ -389,7 +395,7 @@ not supported." (extern-alien "wait" (function pid-t (* int))) (sb-sys:vector-sap ptr))))) (if (minusp pid) - (syscall-error) + (syscall-error 'wait) (values pid (aref ptr 0)))))) #-win32 @@ -407,7 +413,7 @@ not supported." pid-t (* int) int)) pid (sb-sys:vector-sap ptr) options)))) (if (minusp pid) - (syscall-error) + (syscall-error 'waitpid) (values pid (aref ptr 0))))) ;; waitpid macros (define-call "wifexited" boolean never-fails (status int)) @@ -551,7 +557,7 @@ not supported." (,designator-fun ,arg) a-stat))) (when (minusp r) - (syscall-error)) + (syscall-error ',lisp-name)) (alien-to-stat a-stat stat))))))) (define-stat-call #-win32 "stat" #+win32 "_stat" @@ -597,7 +603,7 @@ not supported." (extern-alien "pipe" (function int (* int))) (sb-sys:vector-sap filedes2))))) (when (minusp r) - (syscall-error))) + (syscall-error 'pipe))) (values (aref filedes2 0) (aref filedes2 1)))) #-win32 @@ -630,7 +636,7 @@ not supported." (function int int int (* alien-termios))) fd actions a-termios))) (when (minusp r) - (syscall-error))) + (syscall-error 'tcsetattr))) (values)))) (export 'tcgetattr :sb-posix) (declaim (inline tcgetattr)) @@ -643,7 +649,7 @@ not supported." (file-descriptor fd) a-termios))) (when (minusp r) - (syscall-error)) + (syscall-error 'tcgetattr)) (setf termios (alien-to-termios a-termios termios)))) termios) (define-call "tcdrain" int minusp (fd file-descriptor)) @@ -662,7 +668,7 @@ not supported." a-termios speed))) (when (minusp r) - (syscall-error)) + (syscall-error 'cfsetispeed)) (setf termios (alien-to-termios a-termios termios)))) termios) (export 'cfsetospeed :sb-posix) @@ -676,7 +682,7 @@ not supported." a-termios speed))) (when (minusp r) - (syscall-error)) + (syscall-error 'cfsetospeed)) (setf termios (alien-to-termios a-termios termios)))) termios) (export 'cfgetispeed :sb-posix) @@ -707,7 +713,7 @@ not supported." (function time-t (* time-t))) nil))) (if (minusp result) - (syscall-error) + (syscall-error 'time) result))) (export 'utime :sb-posix) (defun utime (filename &optional access-time modification-time) @@ -721,7 +727,7 @@ not supported." (slot utimbuf 'modtime) (or modification-time 0)) (let ((result (alien-funcall fun name (alien-sap utimbuf)))) (if (minusp result) - (syscall-error) + (syscall-error 'utime) result)))))) (export 'utimes :sb-posix) (defun utimes (filename &optional access-time modification-time) @@ -731,7 +737,7 @@ not supported." (values integer (cl:truncate (* fractional 1000000))))) (maybe-syscall-error (value) (if (minusp value) - (syscall-error) + (syscall-error 'utimes) value))) (let ((fun (extern-alien "utimes" (function int (c-string :not-null t) (* (array alien-timeval 2))))) diff --git a/contrib/sb-posix/macros.lisp b/contrib/sb-posix/macros.lisp index e9ec78b..95d25b7 100644 --- a/contrib/sb-posix/macros.lisp +++ b/contrib/sb-posix/macros.lisp @@ -119,7 +119,7 @@ a FILE-STREAM designating the underlying file-descriptor." ,(car x)) (car x))) arguments)))) - (if (,error-predicate r) (syscall-error) r)))) + (if (,error-predicate r) (syscall-error ',lisp-name) r)))) `(sb-int:style-warn "Didn't find definition for ~S" ,c-name))) (defmacro define-call (name return-type error-predicate &rest arguments) diff --git a/version.lisp-expr b/version.lisp-expr index 61db4e8..979193a 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -20,4 +20,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.48.26" +"1.0.48.27"