X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-posix%2Finterface.lisp;h=541c3c96fd65ba672b1e1a7d05160655af4f2e26;hb=b8f49ceae4a3b513de21f385bb784729d2ddff3f;hp=7bc574b6e2c4b91ff01f65de7d9386de07580f08;hpb=0b85642df140fabd8f0a91c85edff0543dc359b1;p=sbcl.git

diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp
index 7bc574b..541c3c9 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))
@@ -397,8 +466,8 @@
       (declaim (inline ,lisp-name))
       (defun ,lisp-name (,arg)
         (let ((r (alien-funcall (extern-alien ,name ,type) ,arg)))
-          (if (null r)
-              r
+          (if (null-alien r)
+              nil
               (alien-to-passwd r)))))))
 
 (define-pw-call "getpwnam" login-name (function (* alien-passwd) c-string))
@@ -420,8 +489,8 @@
       (declaim (inline ,lisp-name))
       (defun ,lisp-name (,arg)
         (let ((r (alien-funcall (extern-alien ,name ,type) ,arg)))
-          (if (null r)
-              r
+          (if (null-alien r)
+              nil
               (alien-to-group r)))))))
 
 (define-gr-call "getgrnam" login-name (function (* alien-group) c-string))