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

Diff of /slime/swank.lisp

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

revision 1.152 by lgorrie, Mon Mar 22 13:56:39 2004 UTC revision 1.153 by heller, Tue Mar 23 21:23:09 2004 UTC
# Line 31  Line 31 
31    
32  (in-package :swank)  (in-package :swank)
33    
34  (declaim (optimize (debug 2)))  (declaim (optimize (debug 3)))
35    
36  (defvar *swank-io-package*  (defvar *swank-io-package*
37    (let ((package (make-package "SWANK-IO-PACKAGE" :use '())))    (let ((package (make-package :swank-io-package :use '())))
38      (import '(nil t quote) package)      (import '(nil t quote) package)
39      package))      package))
40    
# Line 55  Line 55 
55      (defun ,fun ,@rest)      (defun ,fun ,@rest)
56      (export ',fun :swank)))      (export ',fun :swank)))
57    
 (defmacro defslimefun-unimplemented (fun args)  
   `(progn  
     (defun ,fun ,args  
       (declare (ignore ,@args))  
       (error "Backend function ~A not implemented." ',fun))  
     (export ',fun :swank)))  
   
58  (declaim (ftype (function () nil) missing-arg))  (declaim (ftype (function () nil) missing-arg))
59  (defun missing-arg ()  (defun missing-arg ()
60    (error "A required &KEY or &OPTIONAL argument was not supplied."))    (error "A required &KEY or &OPTIONAL argument was not supplied."))
# Line 130  and to detect situations where interrupt Line 123  and to detect situations where interrupt
123    
124  ;;;; Helper macros  ;;;; Helper macros
125    
126    (defmacro with-connection ((connection) &body body)
127      "Execute BODY in the context of CONNECTION."
128      `(let ((*emacs-connection* ,connection))
129        (catch 'slime-toplevel
130          (with-simple-restart (abort "Return to SLIME toplevel.")
131            (with-io-redirection (*emacs-connection*)
132              (let ((*debugger-hook* #'swank-debugger-hook))
133                ,@body))))))
134    
135  (defmacro with-io-redirection ((connection) &body body)  (defmacro with-io-redirection ((connection) &body body)
136    "Execute BODY with I/O redirection to CONNECTION.    "Execute BODY with I/O redirection to CONNECTION.
137  If *REDIRECT-IO* is true, all standard I/O streams are redirected."  If *REDIRECT-IO* is true, all standard I/O streams are redirected."
# Line 231  Redirection is done while Lisp is proces Line 233  Redirection is done while Lisp is proces
233    (when *swank-debug-p*    (when *swank-debug-p*
234      (format *debug-io* "~&;; Swank started at port: ~D.~%" port)))      (format *debug-io* "~&;; Swank started at port: ~D.~%" port)))
235    
236  (defun open-streams (socket-io)  (defun open-streams (connection)
237    "Return the 4 streams for IO redirection:    "Return the 4 streams for IO redirection:
238   DEDICATED-OUTPUT INPUT OUTPUT IO"   DEDICATED-OUTPUT INPUT OUTPUT IO"
239    (multiple-value-bind (output-fn dedicated-output)    (multiple-value-bind (output-fn dedicated-output)
240        (make-output-function socket-io)        (make-output-function connection)
241      (let ((input-fn  (lambda () (read-user-input-from-emacs))))      (let ((input-fn  (lambda ()
242                           (with-connection (connection)
243                             (read-user-input-from-emacs)))))
244        (multiple-value-bind (in out) (make-fn-streams input-fn output-fn)        (multiple-value-bind (in out) (make-fn-streams input-fn output-fn)
245          (let ((out (or dedicated-output out)))          (let ((out (or dedicated-output out)))
246            (let ((io (make-two-way-stream in out)))            (let ((io (make-two-way-stream in out)))
247              (values dedicated-output in out io)))))))              (values dedicated-output in out io)))))))
248    
249  (defun make-output-function (socket-io)  (defun make-output-function (connection)
250    "Create function to send user output to Emacs.    "Create function to send user output to Emacs.
251  This function may open a dedicated socket to send output. It  This function may open a dedicated socket to send output. It
252  returns two values: the output function, and the dedicated  returns two values: the output function, and the dedicated
253  stream (or NIL if none was created)."  stream (or NIL if none was created)."
254    (if *use-dedicated-output-stream*    (if *use-dedicated-output-stream*
255        (let ((stream (open-dedicated-output-stream socket-io)))        (let ((stream (open-dedicated-output-stream
256                         (connection.socket-io connection))))
257          (values (lambda (string)          (values (lambda (string)
258                    (write-string string stream)                    (write-string string stream)
259                    (force-output stream))                    (force-output stream))
260                  stream))                  stream))
261        (values (lambda (string) (send-output-to-emacs string socket-io))        (values (lambda (string)
262                    (with-connection (connection)
263                      (send-to-emacs `(:read-output ,string))))
264                nil)))                nil)))
265    
266  (defun open-dedicated-output-stream (socket-io)  (defun open-dedicated-output-stream (socket-io)
# Line 266  This is an optimized way for Lisp to del Line 273  This is an optimized way for Lisp to del
273      (encode-message `(:open-dedicated-output-stream ,port) socket-io)      (encode-message `(:open-dedicated-output-stream ,port) socket-io)
274      (accept-connection socket)))      (accept-connection socket)))
275    
 (defmacro with-connection ((connection) &body body)  
   "Execute BODY in the context of CONNECTION."  
   `(let ((*emacs-connection* ,connection))  
     (catch 'slime-toplevel  
       (with-simple-restart (abort "Return to SLIME toplevel.")  
         (with-io-redirection (connection)  
           (let ((*debugger-hook* #'swank-debugger-hook))  
             ,@body))))))  
   
276  (defun handle-request (connection)  (defun handle-request (connection)
277    "Read and process one request.  The processing is done in the extend    "Read and process one request.  The processing is done in the extend
278  of the toplevel restart."  of the toplevel restart."
# Line 421  element." Line 419  element."
419       (declare (ignore _))       (declare (ignore _))
420       (encode-message event socket-io))))       (encode-message event socket-io))))
421    
422    (defun spawn-threads-for-connection (connection)
423      (let ((socket-io (connection.socket-io connection)))
424        (let ((control-thread (spawn (lambda ()
425                                       (dispatch-loop socket-io connection))
426                                     :name "control-thread")))
427          (setf (connection.control-thread connection) control-thread)
428          (let ((reader-thread (spawn (lambda ()
429                                        (read-loop control-thread socket-io
430                                                   connection))
431                                      :name "reader-thread")))
432            (setf (connection.reader-thread connection) reader-thread)
433            connection))))
434    
435    (defun initialize-streams-for-connection (connection)
436      (multiple-value-bind (dedicated in out io) (open-streams connection)
437        (setf (connection.dedicated-output connection) dedicated
438              (connection.user-io connection)          io
439              (connection.user-output connection)      out
440              (connection.user-input connection)       in)
441        connection))
442    
443  (defun create-connection (socket-io style)  (defun create-connection (socket-io style)
444    (multiple-value-bind (dedicated in out io) (open-streams socket-io)    (initialize-streams-for-connection
445      (ecase style     (ecase style
446        (:spawn       (:spawn
447         (let ((connection        (make-connection :socket-io socket-io
448                (make-connection :socket-io socket-io :dedicated-output dedicated                         :read #'read-from-control-thread
449                                 :user-input in :user-output out :user-io io                         :send #'send-to-control-thread
450                                 :read #'read-from-control-thread                         :serve-requests #'spawn-threads-for-connection))
451                                 :send #'send-to-control-thread       (:sigio
452                                 :serve-requests (lambda (c) c))))        (make-connection :socket-io socket-io
453           (let ((control-thread (spawn (lambda ()                         :read #'read-from-socket-io
454                                          (dispatch-loop socket-io connection))                         :send #'send-to-socket-io
455                                        :name "control-thread")))                         :serve-requests #'install-sigio-handler
456             (setf (connection.control-thread connection) control-thread)                         :cleanup #'deinstall-sigio-handler))
457             (let ((reader-thread (spawn (lambda ()       (:fd-handler
458                                           (read-loop control-thread        (make-connection :socket-io socket-io
459                                                      socket-io                         :read #'read-from-socket-io
460                                                      connection))                         :send #'send-to-socket-io
461                                         :name "reader-thread")))                         :serve-requests #'install-fd-handler
462               (setf (connection.reader-thread connection) reader-thread)                         :cleanup #'deinstall-fd-handler))
463               connection))))       ((nil)
464        (:sigio        (make-connection :socket-io socket-io
465         (make-connection :socket-io socket-io :dedicated-output dedicated                         :read #'read-from-socket-io
466                          :user-input in :user-output out :user-io io                         :send #'send-to-socket-io
467                          :read #'read-from-socket-io                         :serve-requests #'simple-serve-requests)))))
                         :send #'send-to-socket-io  
                         :serve-requests #'install-sigio-handler  
                         :cleanup #'deinstall-fd-handler))  
       (:fd-handler  
        (make-connection :socket-io socket-io :dedicated-output dedicated  
                         :user-input in :user-output out :user-io io  
                         :read #'read-from-socket-io  
                         :send #'send-to-socket-io  
                         :serve-requests #'install-fd-handler  
                         :cleanup #'deinstall-fd-handler))  
       ((nil)  
        (make-connection :socket-io socket-io :dedicated-output dedicated  
                         :user-input in :user-output out :user-io io  
                         :read #'read-from-socket-io  
                         :send #'send-to-socket-io  
                         :serve-requests #'simple-serve-requests)))))  
468    
469  (defun process-available-input (stream fn)  (defun process-available-input (stream fn)
470    (loop while (and (open-stream-p stream)    (loop while (and (open-stream-p stream)
# Line 655  If a protocol error occurs then a SLIME- Line 658  If a protocol error occurs then a SLIME-
658  (defun clear-user-input  ()  (defun clear-user-input  ()
659    (clear-input (connection.user-input *emacs-connection*)))    (clear-input (connection.user-input *emacs-connection*)))
660    
 (defun send-output-to-emacs (string socket-io)  
   (encode-message `(:read-output ,string) socket-io))  
   
661  (defvar *read-input-catch-tag* 0)  (defvar *read-input-catch-tag* 0)
662    
663  (defun read-user-input-from-emacs ()  (defun read-user-input-from-emacs ()
# Line 715  buffer are best read in this package.  S Line 715  buffer are best read in this package.  S
715  (defun guess-package-from-string (name &optional (default-package *package*))  (defun guess-package-from-string (name &optional (default-package *package*))
716    (or (and name    (or (and name
717             (or (find-package name)             (or (find-package name)
718                 (find-package (string-upcase name))))                 (find-package (string-upcase name))
719                   (find-package (substitute #\- #\! name))))
720        default-package))        default-package))
721    
722  (defun find-symbol-designator (string &optional  (defun find-symbol-designator (string &optional
# Line 1389  Examples: Line 1390  Examples:
1390    
1391  ;;;;; Extending the input string by completion  ;;;;; Extending the input string by completion
1392    
1393  ;; XXX (longest-completion '("muffle-warning" "multiple-value-bind"))  ;; XXX (longest-completion '("muffle-warning" "multiple-value-bind"))
1394  ;;     => "mu-".  Shouldn't that be "mu"?  ;;     => "mu-".  Shouldn't that be "mu"?
1395  (defun longest-completion (completions)  (defun longest-completion (completions)
1396    "Return the longest prefix for all COMPLETIONS."    "Return the longest prefix for all COMPLETIONS."
# Line 1461  For example: Line 1462  For example:
1462    "Make an apropos search for Emacs.    "Make an apropos search for Emacs.
1463  The result is a list of property lists."  The result is a list of property lists."
1464    (let ((package (if package    (let ((package (if package
1465                       (or (find-package (read-from-string package))                       (or (find-package package)
1466                           (error "No such package: ~S" package)))))                           (error "No such package: ~S" package)))))
1467      (mapcan (listify #'briefly-describe-symbol-for-emacs)      (mapcan (listify #'briefly-describe-symbol-for-emacs)
1468              (sort (apropos-symbols name external-only package)              (sort (remove-duplicates
1469                       (apropos-symbols name external-only package))
1470                    #'present-symbol-before-p))))                    #'present-symbol-before-p))))
1471    
1472  (defun briefly-describe-symbol-for-emacs (symbol)  (defun briefly-describe-symbol-for-emacs (symbol)
# Line 1714  The result is a list of the form ((LOCAT Line 1716  The result is a list of the form ((LOCAT
1716            :type (to-string (type-of object))            :type (to-string (type-of object))
1717            :primitive-type (describe-primitive-type object)            :primitive-type (describe-primitive-type object)
1718            :parts (loop for (label . value) in parts            :parts (loop for (label . value) in parts
1719                         collect (cons label                         collect (cons (princ-to-string label)
1720                                       (print-part-to-string value))))))                                       (print-part-to-string value))))))
1721    
1722  (defun nth-part (index)  (defun nth-part (index)

Legend:
Removed from v.1.152  
changed lines
  Added in v.1.153

  ViewVC Help
Powered by ViewVC 1.1.5