/[slime]/slime/swank.lisp
ViewVC logotype

Diff of /slime/swank.lisp

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

revision 1.389 by heller, Thu Aug 10 11:53:35 2006 UTC revision 1.390 by heller, Fri Aug 11 16:25:59 2006 UTC
# Line 253  recently established one." Line 253  recently established one."
253    "Return the value of *SWANK-STATE-STACK*."    "Return the value of *SWANK-STATE-STACK*."
254    *swank-state-stack*)    *swank-state-stack*)
255    
256  (define-condition slime-protocol-error (error)  ;; A conditions to include backtrace information
257    ((condition :initarg :condition :reader slime-protocol-error.condition))  (define-condition swank-error (error)
258      ((condition :initarg :condition :reader swank-error.condition)
259       (backtrace :initarg :backtrace :reader swank-error.backtrace))
260    (:report (lambda (condition stream)    (:report (lambda (condition stream)
261               (format stream "~A" (slime-protocol-error.condition condition)))))               (princ (swank-error.condition condition) stream))))
262    
263    (defun make-swank-error (condition)
264      (let ((bt (ignore-errors
265                  (call-with-debugging-environment
266                   (lambda ()(backtrace 0 nil))))))
267        (make-condition 'swank-error :condition condition :backtrace bt)))
268    
269  (add-hook *new-connection-hook* 'notify-backend-of-connection)  (add-hook *new-connection-hook* 'notify-backend-of-connection)
270  (defun notify-backend-of-connection (connection)  (defun notify-backend-of-connection (connection)
# Line 424  connections, otherwise it will be closed Line 432  connections, otherwise it will be closed
432               (serve-connection socket style dont-close external-format)))               (serve-connection socket style dont-close external-format)))
433        (ecase style        (ecase style
434          (:spawn          (:spawn
435           (spawn (lambda () (loop do (ignore-errors (serve)) while dont-close))           (spawn (lambda () (loop do (ignore-errors (serve)) while dont-close))
436                  :name "Swank"))                  :name "Swank"))
437          ((:fd-handler :sigio)          ((:fd-handler :sigio)
438           (add-fd-handler socket (lambda () (serve))))           (add-fd-handler socket (lambda () (serve))))
# Line 556  of the toplevel restart." Line 564  of the toplevel restart."
564  (defun current-socket-io ()  (defun current-socket-io ()
565    (connection.socket-io *emacs-connection*))    (connection.socket-io *emacs-connection*))
566    
567  (defun close-connection (c &optional condition)  (defun close-connection (c &optional condition backtrace)
568      (format *debug-io* "~&;; swank:close-connection: ~A~%" condition)
569    (let ((cleanup (connection.cleanup c)))    (let ((cleanup (connection.cleanup c)))
570      (when cleanup      (when cleanup
571        (funcall cleanup c)))        (funcall cleanup c)))
# Line 565  of the toplevel restart." Line 574  of the toplevel restart."
574      (close (connection.dedicated-output c)))      (close (connection.dedicated-output c)))
575    (setf *connections* (remove c *connections*))    (setf *connections* (remove c *connections*))
576    (run-hook *connection-closed-hook* c)    (run-hook *connection-closed-hook* c)
577    (when condition    (when (and condition (not (typep condition 'end-of-file)))
578      (finish-output *debug-io*)      (finish-output *debug-io*)
579      (format *debug-io* "~&;; Event history start:~%")      (format *debug-io* "~&;; Event history start:~%")
580      (dump-event-history *debug-io*)      (dump-event-history *debug-io*)
581      (format *debug-io* ";; Event history end.~%~      (format *debug-io* ";; Event history end.~%~
582                            ;; Backtrace:~%~{~A~%~}~
583                          ;; Connection to Emacs lost. [~%~                          ;; Connection to Emacs lost. [~%~
584                          ;;  condition: ~A~%~                          ;;  condition: ~A~%~
585                          ;;  type: ~S~%~                          ;;  type: ~S~%~
586                          ;;  encoding: ~S style: ~S dedicated: ~S]~%"                          ;;  encoding: ~S style: ~S dedicated: ~S]~%"
587                backtrace
588              (escape-non-ascii (safe-condition-message condition) )              (escape-non-ascii (safe-condition-message condition) )
589              (type-of condition)              (type-of condition)
590              (connection.external-format c)              (connection.external-format c)
# Line 582  of the toplevel restart." Line 593  of the toplevel restart."
593      (finish-output *debug-io*)))      (finish-output *debug-io*)))
594    
595  (defmacro with-reader-error-handler ((connection) &body body)  (defmacro with-reader-error-handler ((connection) &body body)
596    `(handler-case (progn ,@body)    (let ((con (gensym)))
597       (slime-protocol-error (e)      `(let ((,con ,connection))
598         (close-connection ,connection e))))         (handler-case
599               (progn ,@body)
600             (swank-error (e)
601               (close-connection ,con
602                                 (swank-error.condition e)
603                                 (swank-error.backtrace e)))))))
604    
605  (defslimefun simple-break ()  (defslimefun simple-break ()
606    (with-simple-restart  (continue "Continue from interrupt.")    (with-simple-restart  (continue "Continue from interrupt.")
# Line 729  of the toplevel restart." Line 745  of the toplevel restart."
745          (kill-thread thread)))))          (kill-thread thread)))))
746    
747  (defun repl-loop (connection)  (defun repl-loop (connection)
748    (with-connection (connection)    (loop (handle-request connection)))
     (loop (handle-request connection))))  
749    
750  (defun process-available-input (stream fn)  (defun process-available-input (stream fn)
751    (loop while (and (open-stream-p stream)    (loop while (and (open-stream-p stream)
# Line 784  of the toplevel restart." Line 799  of the toplevel restart."
799  ;;;;;; Simple sequential IO  ;;;;;; Simple sequential IO
800    
801  (defun simple-serve-requests (connection)  (defun simple-serve-requests (connection)
802    (with-reader-error-handler (connection)    (unwind-protect
803      (unwind-protect         (with-simple-restart (close-connection "Close SLIME connection")
804           (loop           (with-reader-error-handler (connection)
805            (with-connection (connection)             (loop
806              (with-simple-restart (abort-request "")              (handle-request connection))))
807                (do ()      (close-connection connection)))
                   ((wait-until-readable (connection.socket-io connection))))))  
           (handle-request connection))  
       (close-connection connection))))  
   
 (defun wait-until-readable (stream)  
   (unread-char (read-char stream) stream)  
   t)  
808    
809  (defun read-from-socket-io ()  (defun read-from-socket-io ()
810    (let ((event (decode-message (current-socket-io))))    (let ((event (decode-message (current-socket-io))))
# Line 1052  NIL if streams are not globally redirect Line 1060  NIL if streams are not globally redirect
1060    (receive))    (receive))
1061    
1062  (defun decode-message (stream)  (defun decode-message (stream)
1063    "Read an S-expression from STREAM using the SLIME protocol.    "Read an S-expression from STREAM using the SLIME protocol."
 If a protocol error occurs then a SLIME-PROTOCOL-ERROR is signalled."  
1064    (let ((*swank-state-stack* (cons :read-next-form *swank-state-stack*)))    (let ((*swank-state-stack* (cons :read-next-form *swank-state-stack*)))
1065      (handler-case      (handler-bind ((error (lambda (c) (error (make-swank-error c)))))
1066          (let* ((length (decode-message-length stream))        (let* ((length (decode-message-length stream))
1067                 (string (make-string length))               (string (make-string length))
1068                 (pos (read-sequence string stream)))               (pos (read-sequence string stream)))
1069            (assert (= pos length) ()          (assert (= pos length) ()
1070                    "Short read: length=~D  pos=~D" length pos)                  "Short read: length=~D  pos=~D" length pos)
1071            (log-event "READ: ~S~%" string)          (log-event "READ: ~S~%" string)
1072            (read-form string))          (read-form string)))))
       (serious-condition (c)  
         (error (make-condition 'slime-protocol-error :condition c))))))  
1073    
1074  (defun decode-message-length (stream)  (defun decode-message-length (stream)
1075    (let ((buffer (make-string 6)))    (let ((buffer (make-string 6)))

Legend:
Removed from v.1.389  
changed lines
  Added in v.1.390

  ViewVC Help
Powered by ViewVC 1.1.5