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

Diff of /slime/swank.lisp

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

revision 1.520 by heller, Fri Nov 30 13:09:49 2007 UTC revision 1.521 by heller, Sun Dec 2 08:44:33 2007 UTC
# Line 17  Line 17 
17    (:export #:startup-multiprocessing    (:export #:startup-multiprocessing
18             #:start-server             #:start-server
19             #:create-server             #:create-server
20               #:stop-server
21               #:restart-server
22             #:ed-in-emacs             #:ed-in-emacs
23             #:inspect-in-emacs             #:inspect-in-emacs
24             #:print-indentation-lossage             #:print-indentation-lossage
# Line 583  Valid values are :none, :line, and :full Line 585  Valid values are :none, :line, and :full
585    
586  (defvar *coding-system* "iso-latin-1-unix")  (defvar *coding-system* "iso-latin-1-unix")
587    
588    (defvar *listener-sockets* nil
589      "A property list of lists containing style, socket pairs used
590       by swank server listeners, keyed on socket port number. They
591       are used to close sockets on server shutdown or restart.")
592    
593  (defun start-server (port-file &key (style *communication-style*)  (defun start-server (port-file &key (style *communication-style*)
594                                      (dont-close *dont-close*)                                      (dont-close *dont-close*)
595                                      (coding-system *coding-system*))                                      (coding-system *coding-system*))
# Line 612  connections, otherwise it will be closed Line 619  connections, otherwise it will be closed
619  (defun setup-server (port announce-fn style dont-close external-format)  (defun setup-server (port announce-fn style dont-close external-format)
620    (declare (type function announce-fn))    (declare (type function announce-fn))
621    (let* ((socket (create-socket *loopback-interface* port))    (let* ((socket (create-socket *loopback-interface* port))
622           (port (local-port socket)))           (local-port (local-port socket)))
623      (funcall announce-fn port)      (funcall announce-fn local-port)
624      (flet ((serve ()      (flet ((serve ()
625               (serve-connection socket style dont-close external-format)))               (serve-connection socket style dont-close external-format)))
626        (ecase style        (ecase style
# Line 622  connections, otherwise it will be closed Line 629  connections, otherwise it will be closed
629            (lambda ()            (lambda ()
630              (spawn (lambda ()              (spawn (lambda ()
631                       (loop do (ignore-errors (serve)) while dont-close))                       (loop do (ignore-errors (serve)) while dont-close))
632                     :name "Swank"))))                     :name (concatenate 'string "Swank "
633                                          (princ-to-string port))))))
634          ((:fd-handler :sigio)          ((:fd-handler :sigio)
635           (add-fd-handler socket (lambda () (serve))))           (add-fd-handler socket (lambda () (serve))))
636          ((nil) (loop do (serve) while dont-close)))          ((nil) (loop do (serve) while dont-close)))
637        port)))        (setf (getf *listener-sockets* port) (list style socket))
638          local-port)))
639    
640    (defun stop-server (port)
641      "Stop server running on PORT."
642      (let* ((socket-description (getf *listener-sockets* port))
643             (style (first socket-description))
644             (socket (second socket-description)))
645        (ecase style
646          (:spawn
647           (let ((thread-position
648                  (position-if
649                   (lambda (x)
650                     (string-equal (first x)
651                                   (concatenate 'string "Swank "
652                                                (princ-to-string port))))
653                   (list-threads))))
654             (when thread-position
655               (kill-nth-thread thread-position)
656               (close-socket socket)
657               (remf *listener-sockets* port))))
658          ((:fd-handler :sigio)
659           (remove-fd-handlers socket)
660           (close-socket socket)
661           (remf *listener-sockets* port)))))
662    
663    (defun restart-server (&key (port default-server-port)
664                           (style *communication-style*)
665                           (dont-close *dont-close*)
666                           (coding-system *coding-system*))
667      "Stop the server listening on PORT, then start a new SWANK server
668    on PORT running in STYLE. If DONT-CLOSE is true then the listen socket
669    will accept multiple connections, otherwise it will be closed after the
670    first."
671      (stop-server port)
672      (sleep 5)
673      (create-server :port port :style style :dont-close dont-close
674                     :coding-system coding-system))
675    
676    
677  (defun serve-connection (socket style dont-close external-format)  (defun serve-connection (socket style dont-close external-format)
678    (let ((closed-socket-p nil))    (let ((closed-socket-p nil))
# Line 2358  the filename of the module (or nil if th Line 2404  the filename of the module (or nil if th
2404    
2405  ;;;; Simple completion  ;;;; Simple completion
2406    
2407  (defslimefun simple-completions (string buffer-package)  (defslimefun simple-completions (string package)
2408    "Return a list of completions for the string STRING."    "Return a list of completions for the string STRING."
2409    (let ((strings (all-completions string buffer-package #'prefix-match-p)))    (let ((strings (all-completions string package #'prefix-match-p)))
2410      (list strings (longest-common-prefix strings))))      (list strings (longest-common-prefix strings))))
2411    
2412  (defun all-completions (string buffer-package test)  (defun all-completions (string package test)
2413    (multiple-value-bind (name pname intern) (tokenize-symbol string)    (multiple-value-bind (name pname intern) (tokenize-symbol string)
2414      (let* ((extern (and pname (not intern)))      (let* ((extern (and pname (not intern)))
2415             (pack (cond ((equal pname "") keyword-package)             (pack (cond ((equal pname "") keyword-package)
2416                         ((not pname) (guess-buffer-package buffer-package))                         ((not pname) (guess-buffer-package package))
2417                         (t (guess-package pname))))                         (t (guess-package pname))))
2418             (test (lambda (sym) (funcall test name (unparse-symbol sym))))             (test (lambda (sym) (funcall test name (unparse-symbol sym))))
2419             (syms (and pack (matching-symbols pack extern test))))             (syms (and pack (matching-symbols pack extern test))))

Legend:
Removed from v.1.520  
changed lines
  Added in v.1.521

  ViewVC Help
Powered by ViewVC 1.1.5