0.7.13.2

[sbcl.git] / src / code / serve-event.lisp

diff --git a/src/code/serve-event.lisp b/src/code/serve-event.lisp
index 92cc9b2..7b1b4e9 100644 (file)
--- a/src/code/serve-event.lisp
+++ b/src/code/serve-event.lisp
@@ -8,9 +8,6 @@
 ;;;; files for more information.
 
 (in-package "SB!IMPL")
-
-(file-comment
-  "$Header$")
 \f
 #|
 ;;;; object set stuff
@@ -24,7 +21,8 @@
                                (default-handler #'default-default-handler)))
            (:print-object
             (lambda (s stream)
-              (format stream "#<Object Set ~S>" (object-set-name s)))))
+              (format stream "#<Object Set ~S>" (object-set-name s))))
+           (:copier nil))
   name                                 ; Name, for descriptive purposes.
   (table (make-hash-table :test 'eq))   ; Message-ID or
                                        ;   xevent-type --> handler fun.
@@ -44,14 +42,14 @@
   #!+sb-doc
   "Return the handler function in Object-Set for the operation specified by
    Message-ID, if none, NIL is returned."
-  (check-type object-set object-set)
-  (check-type message-id fixnum)
+  (enforce-type object-set object-set)
+  (enforce-type message-id fixnum)
   (values (gethash message-id (object-set-table object-set))))
 
 ;;; The setf inverse for Object-Set-Operation.
 (defun %set-object-set-operation (object-set message-id new-value)
-  (check-type object-set object-set)
-  (check-type message-id fixnum)
+  (enforce-type object-set object-set)
+  (enforce-type message-id fixnum)
   (setf (gethash message-id (object-set-table object-set)) new-value))
 
 |#
@@ -59,7 +57,8 @@
 ;;;; file descriptor I/O noise
 
 (defstruct (handler
-           (:constructor make-handler (direction descriptor function)))
+           (:constructor make-handler (direction descriptor function))
+           (:copier nil))
   ;; Reading or writing...
   (direction nil :type (member :input :output))
   ;; File descriptor this handler is tied to.
@@ -71,7 +70,7 @@
 (def!method print-object ((handler handler) stream)
   (print-unreadable-object (handler stream :type t)
     (format stream
-           "~A on ~:[~;BOGUS ~]descriptor ~D: ~S"
+           "~A on ~:[~;BOGUS ~]descriptor ~W: ~S"
            (handler-direction handler)
            (handler-bogus handler)
            (handler-descriptor handler)
@@ -87,9 +86,9 @@
   "Arange to call FUNCTION whenever FD is usable. DIRECTION should be
   either :INPUT or :OUTPUT. The value returned should be passed to
   SYSTEM:REMOVE-FD-HANDLER when it is no longer needed."
-  (assert (member direction '(:input :output))
-         (direction)
-         "Invalid direction ~S, must be either :INPUT or :OUTPUT" direction)
+  (unless (member direction '(:input :output))
+    ;; FIXME: should be TYPE-ERROR?
+    (error "Invalid direction ~S, must be either :INPUT or :OUTPUT" direction))
   (let ((handler (make-handler direction fd function)))
     (push handler *descriptor-handlers*)
     handler))
@@ -156,7 +155,7 @@
     (real
      (multiple-value-bind (q r) (truncate (coerce timeout 'single-float))
        (declare (type index q) (single-float r))
-       (values q (the index (truncate (* r 1f6))))))
+       (values q (the (values index t) (truncate (* r 1f6))))))
     (t
      (error "Timeout is not a real number or NIL: ~S" timeout))))
 
@@ -186,9 +185,9 @@
                      (values sec usec))))
              (values 0 0))
        (declare (type (unsigned-byte 31) stop-sec stop-usec))
-       (with-fd-handler (fd direction #'(lambda (fd)
-                                          (declare (ignore fd))
-                                          (setf usable t)))
+       (with-fd-handler (fd direction (lambda (fd)
+                                        (declare (ignore fd))
+                                        (setf usable t)))
          (loop
            (sub-serve-event to-sec to-usec)
 
@@ -283,8 +282,7 @@
 ;;; polling function if it does time out. One important use of this
 ;;; is to periodically call process-yield.
 (declaim (type (or null function) *periodic-polling-function*))
-(defvar *periodic-polling-function*
-  #!-mp nil #!+mp #'sb!mp:process-yield)
+(defvar *periodic-polling-function* nil)
 (declaim (type (unsigned-byte 29) *max-event-to-sec* *max-event-to-usec*))
 (defvar *max-event-to-sec* 1)
 (defvar *max-event-to-usec* 0)
@@ -308,10 +306,11 @@
     (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set))
                          (write-fds (sb!alien:struct sb!unix:fd-set)))
       (let ((count (calc-masks)))
-       (multiple-value-bind (value err) (sb!unix:unix-fast-select
-            count
-            (sb!alien:addr read-fds) (sb!alien:addr write-fds)
-            nil to-sec to-usec)
+       (multiple-value-bind (value err)
+           (sb!unix:unix-fast-select count
+                                     (sb!alien:addr read-fds)
+                                     (sb!alien:addr write-fds)
+                                     nil to-sec to-usec)
        
          ;; Now see what it was (if anything)
          (cond (value