sb-posix: make SYSCALL-ERROR's argument optional

[sbcl.git] / contrib / sb-posix / interface.lisp

diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp
index 3ac862e..4669aaf 100644 (file)
--- a/contrib/sb-posix/interface.lisp
+++ b/contrib/sb-posix/interface.lisp
@@ -61,14 +61,25 @@
       (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))))))
-
-(defun syscall-error ()
-  (error 'sb-posix:syscall-error :errno (get-errno)))
+             (let ((errno (sb-posix:syscall-errno c))
+                   (name (sb-posix:syscall-name c)))
+               (if name
+                   (format s "Error in ~S: ~A (~A)"
+                           name
+                           (sb-int:strerror errno)
+                           errno)
+                   (format s "Error in syscall: ~A (~A)"
+                           (sb-int:strerror errno)
+                           errno))))))
+
+(declaim (ftype (function (&optional symbol) nil) syscall-error))
+(defun syscall-error (&optional 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 +206,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 +368,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 +386,7 @@ not supported."
           (cond (result
                  (buf))
                 ((/= (get-errno) sb-posix:erange)
-                 (syscall-error))))))))
+                 (syscall-error 'getcwd))))))))
 
 #-win32
 (progn
@@ -389,7 +400,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 +418,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 +562,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 +608,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 +641,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 +654,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 +673,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 +687,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 +718,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 +732,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 +742,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)))))