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

Diff of /slime/swank.lisp

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

revision 1.515 by trittweiler, Fri Nov 23 08:25:52 2007 UTC revision 1.516 by heller, Sat Nov 24 07:58:43 2007 UTC
# Line 103  Redirection is done while Lisp is proces Line 103  Redirection is done while Lisp is proces
103      (*print-array*            . t)      (*print-array*            . t)
104      (*print-lines*            . 10)      (*print-lines*            . 10)
105      (*print-escape*           . t)      (*print-escape*           . t)
106      (*print-right-margin*     . 70))      (*print-right-margin*     . ,most-positive-fixnum))
107    "A set of printer variables used in the debugger.")    "A set of printer variables used in the debugger.")
108    
109  (defvar *default-worker-thread-bindings* '()  (defvar *default-worker-thread-bindings* '()
# Line 582  Valid values are :none, :line, and :full Line 582  Valid values are :none, :line, and :full
582                                      (coding-system *coding-system*))                                      (coding-system *coding-system*))
583    "Start the server and write the listen port number to PORT-FILE.    "Start the server and write the listen port number to PORT-FILE.
584  This is the entry point for Emacs."  This is the entry point for Emacs."
585    (flet ((start-server-aux ()    (setup-server 0 (lambda (port)
586             (setup-server 0 (lambda (port)                      (announce-server-port port-file port))
587                               (announce-server-port port-file port))                  style dont-close
588                           style dont-close                  (find-external-format-or-lose coding-system)))
                          (find-external-format-or-lose coding-system))))  
     (if (eq style :spawn)  
         (initialize-multiprocessing #'start-server-aux)  
         (start-server-aux))))  
589    
590  (defun create-server (&key (port default-server-port)  (defun create-server (&key (port default-server-port)
591                        (style *communication-style*)                        (style *communication-style*)
# Line 616  connections, otherwise it will be closed Line 612  connections, otherwise it will be closed
612               (serve-connection socket style dont-close external-format)))               (serve-connection socket style dont-close external-format)))
613        (ecase style        (ecase style
614          (:spawn          (:spawn
615           (spawn (lambda () (loop do (ignore-errors (serve)) while dont-close))           (initialize-multiprocessing
616                  :name "Swank"))            (lambda ()
617                (spawn (lambda ()
618                         (loop do (ignore-errors (serve)) while dont-close))
619                       :name "Swank"))))
620          ((:fd-handler :sigio)          ((:fd-handler :sigio)
621           (add-fd-handler socket (lambda () (serve))))           (add-fd-handler socket (lambda () (serve))))
622          ((nil) (loop do (serve) while dont-close)))          ((nil) (loop do (serve) while dont-close)))
# Line 2017  conditions are simply reported." Line 2016  conditions are simply reported."
2016  (defun safe-condition-message (condition)  (defun safe-condition-message (condition)
2017    "Safely print condition to a string, handling any errors during    "Safely print condition to a string, handling any errors during
2018  printing."  printing."
2019    (let ((*print-pretty* t))    (let ((*print-pretty* t) (*print-right-margin* 65))
2020      (handler-case      (handler-case
2021          (format-sldb-condition condition)          (format-sldb-condition condition)
2022        (error (cond)        (error (cond)
# Line 2481  that symbols accessible in the current p Line 2480  that symbols accessible in the current p
2480                       (string< (symbol-name x) (symbol-name y))                       (string< (symbol-name x) (symbol-name y))
2481                       (string< (package-name px) (package-name py)))))))))                       (string< (package-name px) (package-name py)))))))))
2482    
2483  (let ((regex-hash (make-hash-table :test #'equal)))  (defun make-apropos-matcher (pattern case-sensitive)
2484    (defun compiled-regex (regex-string)    (let ((chr= (if case-sensitive #'char= #'char-equal)))
     (or (gethash regex-string regex-hash)  
         (setf (gethash regex-string regex-hash)  
               (if (zerop (length regex-string))  
                   (lambda (s) (check-type s string) t)  
                   (compile nil (slime-nregex:regex-compile regex-string)))))))  
   
 (defun make-regexp-matcher (string case-sensitive)  
   (let* ((case-modifier (if case-sensitive #'string #'string-upcase))  
          (regex (compiled-regex (funcall case-modifier string))))  
2485      (lambda (symbol)      (lambda (symbol)
2486        (funcall regex (funcall case-modifier symbol)))))        (search pattern (string symbol) :test chr=))))
2487    
2488  (defun apropos-symbols (string external-only case-sensitive package)  (defun apropos-symbols (string external-only case-sensitive package)
2489    (let ((packages (or package (remove (find-package :keyword)    (let ((packages (or package (remove (find-package :keyword)
2490                                        (list-all-packages))))                                        (list-all-packages))))
2491          (matcher  (make-regexp-matcher string case-sensitive))          (matcher  (make-apropos-matcher string case-sensitive))
2492          (result))          (result))
2493      (with-package-iterator (next packages :external :internal)      (with-package-iterator (next packages :external :internal)
2494        (loop (multiple-value-bind (morep symbol) (next)        (loop (multiple-value-bind (morep symbol) (next)

Legend:
Removed from v.1.515  
changed lines
  Added in v.1.516

  ViewVC Help
Powered by ViewVC 1.1.5