1.0.16.4: correct nested DX reasoning

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

diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp
index 5704d3f..110a4ea 100644 (file)
--- a/contrib/sb-posix/interface.lisp
+++ b/contrib/sb-posix/interface.lisp
@@ -63,23 +63,8 @@
                (format s "System call error ~A (~A)"
                        errno (sb-int:strerror 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)))
+  (error 'sb-posix:syscall-error :errno (get-errno)))
 
 (defun unsupported-error (lisp-name c-name)
   (error "~S is unsupported by SBCL on this platform due to lack of ~A()."
@@ -89,60 +74,6 @@
   (warn "~S is unsupported by SBCL on this platform due to lack of ~A()."
         lisp-name c-name))
 
-;; 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))
@@ -290,11 +221,32 @@
   (define-call-internally fcntl-with-pointer-arg "fcntl" int minusp
                           (fd file-descriptor) (cmd int)
                           (arg alien-pointer-to-anything-or-nil))
+  (define-protocol-class flock alien-flock ()
+   ((type :initarg :type :accessor flock-type
+          :documentation "Type of lock; F_RDLCK, F_WRLCK, F_UNLCK.")
+    (whence :initarg :whence :accessor flock-whence
+            :documentation "Flag for starting offset.")
+    (start :initarg :start :accessor flock-start
+           :documentation "Relative offset in bytes.")
+    (len :initarg :len :accessor flock-len
+         :documentation "Size; if 0 then until EOF.")
+    ;; Note: PID isn't initable, and is read-only.  But other stuff in
+    ;; SB-POSIX right now loses when a protocol-class slot is unbound,
+    ;; so we initialize it to 0.
+    (pid :initform 0 :reader flock-pid
+         :documentation
+         "Process ID of the process holding the lock; returned with F_GETLK."))
+   (:documentation "Class representing locks used in fcntl(2)."))
   (define-entry-point "fcntl" (fd cmd &optional (arg nil argp))
     (if argp
         (etypecase arg
           ((alien int) (fcntl-with-int-arg fd cmd arg))
-          ((or (alien (* t)) null) (fcntl-with-pointer-arg fd cmd arg)))
+          ((or (alien (* t)) null) (fcntl-with-pointer-arg fd cmd arg))
+          (flock (with-alien-flock a-flock ()
+                   (flock-to-alien arg a-flock)
+                   (let ((r (fcntl-with-pointer-arg fd cmd a-flock)))
+                     (alien-to-flock a-flock arg)
+                     r))))
         (fcntl-without-arg fd cmd)))
 
   ;; uid, gid