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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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"