/[cmucl]/src/code/serve-event.lisp
ViewVC logotype

Diff of /src/code/serve-event.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.13 by ram, Tue Jan 21 12:56:48 1992 UTC revision 1.13.1.1 by wlott, Tue Jan 28 07:57:51 1992 UTC
# Line 36  Line 36 
36    "*In-server* is set to T when the SIGMSG interrupt has been enabled    "*In-server* is set to T when the SIGMSG interrupt has been enabled
37    in Server.")    in Server.")
38    
 #|  
   
 (defvar server-unique-object (cons 1 2)  
   "Object thrown by the message interrupt handler.")  
   
 (defconstant server-message-size 4096)  
 (defalien server-message server-message (bytes server-message-size) 0)  
   
 (define-alien-stack server-message server-message (bytes server-message-size))  
   
 (defrecord server-message  
   (msg mach:msg #.(record-size 'mach:msg)))  
   
 ;;; Grab-message-loop calls the appropiate handler for an IPC message.  
 (defun grab-message-loop ()  
   (let ((done-any nil))  
     (loop  
       (if (eql (server-grab-message)  
                mach:rcv-timed-out)  
         (return done-any)  
         (setf done-any t)))))  
   
   
 (defun server-grab-message ()  
   (with-stack-alien (sm server-message)  
     (alien-bind ((msg (server-message-msg (alien-value sm))))  
       (setf (alien-access (mach:msg-msgsize (alien-value msg)))  
             server-message-size)  
       (setf (alien-access (mach:msg-localport (alien-value msg)))  
             mach::port-enabled)  
       (let ((gr (mach:msg-receive (alien-value sm) mach::rcv-timeout 0)))  
         (when (eql gr mach:rcv-timed-out)  
           (return-from server-grab-message gr))  
         (unless (eql gr mach:rcv-success)  
           (gr-error 'mach:msg-receive gr))  
         (let* ((server-message (alien-value sm))  
                (port (alien-access (mach:msg-localport (alien-value msg))))  
                (id (alien-access (mach:msg-id (alien-value msg))))  
                (x (gethash port *port-table*))  
                (set (cdr x)))  
           (unless x  
             (error "~D is not known to server (operation: ~D)." port id))  
           (let ((gr (funcall (gethash id (object-set-table set)  
                                       (object-set-default-handler set))  
                              (car x))))  
             (unless (eql gr mach:kern-success)  
               (gr-error 'server gr)))))))  
   mach:kern-success)  
 |#  
39    
40    
41  ;;;; File descriptor IO noise.  ;;;; File descriptor IO noise.
# Line 181  Line 132 
132          (stop-sec stop-usec)          (stop-sec stop-usec)
133          (if timeout          (if timeout
134              (multiple-value-bind (okay sec usec)              (multiple-value-bind (okay sec usec)
135                                   (mach:unix-gettimeofday)                                   (unix:unix-gettimeofday)
136                (declare (ignore okay))                (declare (ignore okay))
137                (values (the (unsigned-byte 32) (+ sec timeout))                (values (the (unsigned-byte 32) (+ sec timeout))
138                        usec))                        usec))
# Line 198  Line 149 
149    
150            (when timeout            (when timeout
151              (multiple-value-bind (okay sec usec)              (multiple-value-bind (okay sec usec)
152                                   (mach:unix-gettimeofday)                                   (unix:unix-gettimeofday)
153                (declare (ignore okay))                (declare (ignore okay))
154                (when (or (> sec stop-sec)                (when (or (> sec stop-sec)
155                          (and (= sec stop-sec) (>= usec stop-usec)))                          (and (= sec stop-sec) (>= usec stop-usec)))
# Line 215  Line 166 
166    (let ((bogus-handlers nil))    (let ((bogus-handlers nil))
167      (dolist (handler *descriptor-handlers*)      (dolist (handler *descriptor-handlers*)
168        (unless (or (handler-bogus handler)        (unless (or (handler-bogus handler)
169                    (mach:unix-fstat (handler-descriptor handler)))                    (unix:unix-fstat (handler-descriptor handler)))
170          (setf (handler-bogus handler) t)          (setf (handler-bogus handler) t)
171          (push handler bogus-handlers)))          (push handler bogus-handlers)))
172      (restart-case (error "~S ~[have~;has a~:;have~] bad file descriptor~:P."      (restart-case (error "~S ~[have~;has a~:;have~] bad file descriptor~:P."
# Line 322  Line 273 
273                         (:output (frob writeable))))                         (:output (frob writeable))))
274                     (setf result t)))                     (setf result t)))
275                 result)))                 result)))
276            ((eql readable mach:eintr)            ((eql readable unix:eintr)
277             ;; We did an interrupt.             ;; We did an interrupt.
278             t)             t)
279            (t            (t
# Line 386  Line 337 
337      (multiple-value-bind (count read-mask write-mask except-mask)      (multiple-value-bind (count read-mask write-mask except-mask)
338                           (calc-masks)                           (calc-masks)
339        ;; Do the select.        ;; Do the select.
340        (mach:unix-select count read-mask write-mask except-mask        (unix:unix-select count read-mask write-mask except-mask
341                          timeout-sec timeout-usec))))                          timeout-sec timeout-usec))))

Legend:
Removed from v.1.13  
changed lines
  Added in v.1.13.1.1

  ViewVC Help
Powered by ViewVC 1.1.5