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

Diff of /slime/swank.lisp

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

revision 1.265 by heller, Wed Nov 24 19:52:52 2004 UTC revision 1.266 by heller, Thu Nov 25 19:03:22 2004 UTC
# Line 268  The package is deleted before returning. Line 268  The package is deleted before returning.
268       (unwind-protect (progn ,@body)       (unwind-protect (progn ,@body)
269         (delete-package ,var))))         (delete-package ,var))))
270    
271    (defvar *log-events* nil)
272    (defvar *log-io* *terminal-io*)
273    
274    (defun log-event (format-string &rest args)
275      "Write a message to *terminal-io* when *log-events* is non-nil.
276    Useful for low level debugging."
277      (when *log-events*
278        (apply #'format *log-io* format-string args)
279        (force-output *log-io*)))
280    
281  ;;;; TCP Server  ;;;; TCP Server
282    
283  (defparameter *redirect-io* t  (defparameter *redirect-io* t
# Line 276  Redirection is done while Lisp is proces Line 286  Redirection is done while Lisp is proces
286    
287  (defvar *use-dedicated-output-stream* t)  (defvar *use-dedicated-output-stream* t)
288  (defvar *communication-style* (preferred-communication-style))  (defvar *communication-style* (preferred-communication-style))
 (defvar *log-events* nil)  
289    
290  (defun start-server (port-file &key (style *communication-style*)  (defun start-server (port-file &key (style *communication-style*)
291                       dont-close (external-format *coding-system*))                       dont-close (external-format *coding-system*))
# Line 415  of the toplevel restart." Line 424  of the toplevel restart."
424    (setf *connections* (remove c *connections*))    (setf *connections* (remove c *connections*))
425    (run-hook *connection-closed-hook* c)    (run-hook *connection-closed-hook* c)
426    (when condition    (when condition
427      (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" condition)))      (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" condition)
428        (finish-output *debug-io*)))
429    
430  (defmacro with-reader-error-handler ((connection) &body body)  (defmacro with-reader-error-handler ((connection) &body body)
431    `(handler-case (progn ,@body)    `(handler-case (progn ,@body)
# Line 439  of the toplevel restart." Line 449  of the toplevel restart."
449    
450  (defun dispatch-loop (socket-io connection)  (defun dispatch-loop (socket-io connection)
451    (let ((*emacs-connection* connection))    (let ((*emacs-connection* connection))
452      (loop (with-simple-restart (abort "Restart dispatch loop.")      (handler-case
453              (loop (dispatch-event (receive) socket-io))))))          (loop (dispatch-event (receive) socket-io))
454          (error (e)
455            (close-connection connection e)))))
456    
457  (defun repl-thread (connection)  (defun repl-thread (connection)
458    (let ((thread (connection.repl-thread connection)))    (let ((thread (connection.repl-thread connection)))
# Line 524  of the toplevel restart." Line 536  of the toplevel restart."
536        connection)))        connection)))
537    
538  (defun cleanup-connection-threads (connection)  (defun cleanup-connection-threads (connection)
539    (kill-thread (connection.control-thread connection))    (let ((threads (list (connection.repl-thread connection)
540    (kill-thread (connection.repl-thread connection)))                         (connection.reader-thread connection)
541                           (connection.control-thread connection))))
542        (dolist (thread threads)
543          (unless (equal (current-thread) thread)
544            (kill-thread thread)))))
545    
546  (defun repl-loop (connection)  (defun repl-loop (connection)
547    (with-connection (connection)    (with-connection (connection)
# Line 814  NIL if streams are not globally redirect Line 830  NIL if streams are not globally redirect
830           (*terminal-io* io))           (*terminal-io* io))
831      (funcall function)))      (funcall function)))
832    
 (defvar *log-io* *terminal-io*)  
   
 (defun log-event (format-string &rest args)  
   "Write a message to *terminal-io* when *log-events* is non-nil.  
 Useful for low level debugging."  
   (when *log-events*  
     (apply #'format *log-io* format-string args)  
     (force-output *log-io*)))  
   
833  (defun read-from-emacs ()  (defun read-from-emacs ()
834    "Read and process a request from Emacs."    "Read and process a request from Emacs."
835    (apply #'funcall (funcall (connection.read *emacs-connection*))))    (apply #'funcall (funcall (connection.read *emacs-connection*))))
# Line 1070  Use the string NAME as operator name." Line 1077  Use the string NAME as operator name."
1077         (arglist-to-string (cons name arglist)         (arglist-to-string (cons name arglist)
1078                            (symbol-package symbol))))))                            (symbol-package symbol))))))
1079    
1080    (defun clean-arglist (arglist)
1081      "Remove &whole, &enviroment, and &aux elements from ARGLIST."
1082      (cond ((null arglist) '())
1083            ((member (car arglist) '(&whole &environment))
1084             (clean-arglist (cddr arglist)))
1085            ((eq (car arglist) '&aux)
1086             '())
1087            (t (cons (car arglist) (clean-arglist (cdr arglist))))))
1088    
1089  (defun arglist-to-string (arglist package)  (defun arglist-to-string (arglist package)
1090    "Print the list ARGLIST for display in the echo area.    "Print the list ARGLIST for display in the echo area.
1091  The argument name are printed without package qualifiers and  The argument name are printed without package qualifiers and
1092  pretty printing of (function foo) as #'foo is suppressed."  pretty printing of (function foo) as #'foo is suppressed."
1093      (setq arglist (clean-arglist arglist))
1094    (etypecase arglist    (etypecase arglist
1095      (null "()")      (null "()")
1096      (cons      (cons
1097       (with-output-to-string (*standard-output*)       (with-output-to-string (*standard-output*)
1098         (with-standard-io-syntax         (with-standard-io-syntax
1099           (let ((*package* package)           (let ((*package* package) (*print-case* :downcase)
1100                 (*print-case* :downcase)                 (*print-pretty* t) (*print-circle* nil) (*print-readably* nil)
1101                 (*print-pretty* t)                 (*print-level* 10) (*print-length* 20))
                (*print-circle* nil)  
                (*print-readably* nil)  
                (*print-level* 10)  
                (*print-length* 20))  
1102             (pprint-logical-block (nil nil :prefix "(" :suffix ")")             (pprint-logical-block (nil nil :prefix "(" :suffix ")")
1103               (loop               (loop
1104                (let ((arg (pop arglist)))                (let ((arg (pop arglist)))
# Line 1107  pretty printing of (function foo) as #'f Line 1120  pretty printing of (function foo) as #'f
1120  (progn  (progn
1121    (assert (test-print-arglist '(function cons) "(function cons)"))    (assert (test-print-arglist '(function cons) "(function cons)"))
1122    (assert (test-print-arglist '(quote cons) "(quote cons)"))    (assert (test-print-arglist '(quote cons) "(quote cons)"))
1123    (assert (test-print-arglist '(&key (function #'+)) "(&key (function #'+))")))    (assert (test-print-arglist '(&key (function #'+)) "(&key (function #'+))"))
1124      (assert (test-print-arglist '(&whole x y z) "(y z)"))
1125      (assert (test-print-arglist '(x &aux y z) "(x)"))
1126      (assert (test-print-arglist '(x &environment env y) "(x y)")))
1127  ;; Expected failure:  ;; Expected failure:
1128  ;; (assert (test-print-arglist '(&key ((function f))) "(&key ((function f)))"))  ;; (assert (test-print-arglist '(&key ((function f))) "(&key ((function f)))"))
1129    
# Line 3253  a time.") Line 3269  a time.")
3269    "Interrupt the INDEXth thread and make it start a swank server.    "Interrupt the INDEXth thread and make it start a swank server.
3270  The server port is written to PORT-FILE-NAME."  The server port is written to PORT-FILE-NAME."
3271    (interrupt-thread (nth-thread index)    (interrupt-thread (nth-thread index)
3272                      (lambda ()                      (lambda ()
3273                        (start-server port-file-name nil))))                        (start-server port-file-name :style nil))))
3274    
3275  ;;;; Class browser  ;;;; Class browser
3276    

Legend:
Removed from v.1.265  
changed lines
  Added in v.1.266

  ViewVC Help
Powered by ViewVC 1.1.5