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

Diff of /slime/swank.lisp

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

revision 1.329 by mbaringer, Wed Aug 31 11:27:47 2005 UTC revision 1.330 by heller, Mon Sep 5 13:54:02 2005 UTC
# Line 333  Useful for low level debugging." Line 333  Useful for low level debugging."
333    "When T swank will attempt to create a second connection to    "When T swank will attempt to create a second connection to
334    Emacs which is used just to send output.")    Emacs which is used just to send output.")
335  (defvar *dedicated-output-stream-port* 0  (defvar *dedicated-output-stream-port* 0
336    "Which port we sholud use for the dedicated output stream.")    "Which port we should use for the dedicated output stream.")
337    
338  (defvar *communication-style* (preferred-communication-style))  (defvar *communication-style* (preferred-communication-style))
339    
340  (defun start-server (port-file &key (style *communication-style*)  (defun start-server (port-file &key (style *communication-style*)
# Line 590  of the toplevel restart." Line 591  of the toplevel restart."
591       (encode-message `(:read-string ,(thread-id thread) ,@args) socket-io))       (encode-message `(:read-string ,(thread-id thread) ,@args) socket-io))
592      ((:y-or-n-p thread &rest args)      ((:y-or-n-p thread &rest args)
593       (encode-message `(:y-or-n-p ,(thread-id thread) ,@args) socket-io))       (encode-message `(:y-or-n-p ,(thread-id thread) ,@args) socket-io))
     ((:evaluate-in-emacs string thread &rest args)  
      (encode-message `(:evaluate-in-emacs ,string ,(thread-id thread) ,@args)  
                      socket-io))  
594      ((:read-aborted thread &rest args)      ((:read-aborted thread &rest args)
595       (encode-message `(:read-aborted ,(thread-id thread) ,@args) socket-io))       (encode-message `(:read-aborted ,(thread-id thread) ,@args) socket-io))
596      ((:emacs-return-string thread-id tag string)      ((:emacs-return-string thread-id tag string)
# Line 721  of the toplevel restart." Line 719  of the toplevel restart."
719        ((:return thread &rest args)        ((:return thread &rest args)
720         (declare (ignore thread))         (declare (ignore thread))
721         (send `(:return ,@args)))         (send `(:return ,@args)))
       ((:evaluate-in-emacs string thread &rest args)  
        (send `(:evaluate-in-emacs ,string 0 ,@args)))  
722        (((:read-output :new-package :new-features :debug-condition        (((:read-output :new-package :new-features :debug-condition
723                        :presentation-start :presentation-end                        :presentation-start :presentation-end
724                        :indentation-update :ed :%apply :eval-no-wait                        :indentation-update :ed :%apply :eval-no-wait
# Line 748  of the toplevel restart." Line 744  of the toplevel restart."
744                                 :serve-requests #'spawn-threads-for-connection                                 :serve-requests #'spawn-threads-for-connection
745                                 :cleanup #'cleanup-connection-threads))                                 :cleanup #'cleanup-connection-threads))
746               (:sigio               (:sigio
747                (make-connection :socket-io socket-io                (make-connection :socket-io socket-io
748                                 :read #'read-from-socket-io                                 :read #'read-from-socket-io
749                                 :send #'send-to-socket-io                                 :send #'send-to-socket-io
750                                 :serve-requests #'install-sigio-handler                                 :serve-requests #'install-sigio-handler
751                                 :cleanup #'deinstall-sigio-handler))                                 :cleanup #'deinstall-sigio-handler))
752               (:fd-handler               (:fd-handler
753                (make-connection :socket-io socket-io                (make-connection :socket-io socket-io
754                                 :read #'read-from-socket-io                                 :read #'read-from-socket-io
755                                 :send #'send-to-socket-io                                 :send #'send-to-socket-io
756                                 :serve-requests #'install-fd-handler                                 :serve-requests #'install-fd-handler
757                                 :cleanup #'deinstall-fd-handler))                                 :cleanup #'deinstall-fd-handler))
758               ((nil)               ((nil)
759                (make-connection :socket-io socket-io                (make-connection :socket-io socket-io
760                                 :read #'read-from-socket-io                                 :read #'read-from-socket-io
761                                 :send #'send-to-socket-io                                 :send #'send-to-socket-io
762                                 :serve-requests #'simple-serve-requests)))))                                 :serve-requests #'simple-serve-requests)))))
# Line 978  If a protocol error occurs then a SLIME- Line 974  If a protocol error occurs then a SLIME-
974    
975  (defun encode-message (message stream)  (defun encode-message (message stream)
976    (let* ((string (prin1-to-string-for-emacs message))    (let* ((string (prin1-to-string-for-emacs message))
977           (length (1+ (length string))))           (length (length string)))
978      (log-event "WRITE: ~A~%" string)      (log-event "WRITE: ~A~%" string)
979      (let ((*print-pretty* nil))      (let ((*print-pretty* nil))
980        (format stream "~6,'0x" length))        (format stream "~6,'0x" length))
981      (write-string string stream)      (write-string string stream)
982      (terpri stream)      ;;(terpri stream)
983      (force-output stream)))      (force-output stream)))
984    
985  (defun prin1-to-string-for-emacs (object)  (defun prin1-to-string-for-emacs (object)
# Line 1019  If a protocol error occurs then a SLIME- Line 1015  If a protocol error occurs then a SLIME-
1015          (unless ok          (unless ok
1016            (send-to-emacs `(:read-aborted ,(current-thread) ,tag)))))))            (send-to-emacs `(:read-aborted ,(current-thread) ,tag)))))))
1017    
1018  (defun y-or-n-p-in-emacs (&optional format-string &rest arguments)  (defun y-or-n-p-in-emacs (format-string &rest arguments)
1019    "Like y-or-n-p, but ask in the Emacs minibuffer."    "Like y-or-n-p, but ask in the Emacs minibuffer."
1020    (let ((tag (incf *read-input-catch-tag*))    (let ((tag (incf *read-input-catch-tag*))
1021          (question (if format-string          (question (apply #'format nil format-string arguments)))
                       (apply #'format nil format-string arguments)  
                       "")))  
1022      (force-output)      (force-output)
1023      (send-to-emacs `(:y-or-n-p ,(current-thread) ,tag ,question))      (send-to-emacs `(:y-or-n-p ,(current-thread) ,tag ,question))
1024      (unwind-protect      (catch (intern-catch-tag tag)
1025           (catch (intern-catch-tag tag)        (loop (read-from-emacs)))))
            (loop (read-from-emacs))))))  
1026    
1027  (defslimefun take-input (tag input)  (defslimefun take-input (tag input)
1028    "Return the string INPUT to the continuation TAG."    "Return the string INPUT to the continuation TAG."
1029    (throw (intern-catch-tag tag) input))    (throw (intern-catch-tag tag) input))
1030    
 (defun evaluate-in-emacs (string)  
   (let ((tag (incf *read-input-catch-tag*)))  
     (force-output)  
     (send-to-emacs `(:evaluate-in-emacs ,string ,(current-thread) ,tag))  
     (let ((ok nil))  
       (unwind-protect  
            (prog1 (catch (intern-catch-tag tag)  
                     (loop (read-from-emacs)))  
              (setq ok t))  
         (unless ok  
           (send-to-emacs `(:read-aborted ,(current-thread) ,tag)))))))  
   
1031  (defun eval-in-emacs (form &optional nowait)  (defun eval-in-emacs (form &optional nowait)
1032    "Eval FORM in Emacs."    "Eval FORM in Emacs."
1033    (destructuring-bind (fun &rest args) form    (destructuring-bind (fun &rest args) form
# Line 1115  Emacs buffer." Line 1096  Emacs buffer."
1096          (let ((*readtable* *buffer-readtable*))          (let ((*readtable* *buffer-readtable*))
1097            (call-with-syntax-hooks fun)))))            (call-with-syntax-hooks fun)))))
1098    
1099    (defun to-string (object)
1100      "Write OBJECT in the *BUFFER-PACKAGE*.
1101    The result may not be readable."
1102      (with-buffer-syntax ()
1103        (let ((*print-readably* nil))
1104          (prin1-to-string object))))
1105    
1106  (defun from-string (string)  (defun from-string (string)
1107    "Read string in the *BUFFER-PACKAGE*"    "Read string in the *BUFFER-PACKAGE*"
1108    (with-buffer-syntax ()    (with-buffer-syntax ()
# Line 1173  Return the package or nil." Line 1161  Return the package or nil."
1161               (= (length string) pos))               (= (length string) pos))
1162          (find-package name))))          (find-package name))))
1163    
 (defun to-string (string)  
   "Write string in the *BUFFER-PACKAGE*."  
   (with-buffer-syntax ()  
     (handler-bind ((error (lambda (c)  
                             (declare (ignore c))  
                             (return-from to-string "#<swank: error printing object>"))))  
       (prin1-to-string string))))  
   
1164  (defun guess-package-from-string (name &optional (default-package *package*))  (defun guess-package-from-string (name &optional (default-package *package*))
1165    (or (and name    (or (and name
1166             (or (parse-package name)             (or (parse-package name)
# Line 2015  FORM is expected, but not required, to b Line 1995  FORM is expected, but not required, to b
1995    "Set the value of a setf'able FORM to VALUE.    "Set the value of a setf'able FORM to VALUE.
1996  FORM and VALUE are both strings from Emacs."  FORM and VALUE are both strings from Emacs."
1997    (with-buffer-syntax ()    (with-buffer-syntax ()
1998      (eval `(setf ,(read-from-string form) ,(read-from-string (concatenate 'string "`" value))))      (eval `(setf ,(read-from-string form)
1999                ,(read-from-string (concatenate 'string "`" value))))
2000      t))      t))
2001    
2002    (defun background-message  (format-string &rest args)
2003      "Display a message in Emacs' echo area.
2004    
2005    Use this function for informative messages only.  The message may even
2006    be dropped, if we are too busy with other things."
2007      (when *emacs-connection*
2008        (send-to-emacs `(:background-message
2009                         ,(apply #'format nil format-string args)))))
2010    
2011    
2012  ;;;; Debugger  ;;;; Debugger
2013    
# Line 2481  symbols are returned." Line 2471  symbols are returned."
2471  (defun symbol-external-p (symbol &optional (package (symbol-package symbol)))  (defun symbol-external-p (symbol &optional (package (symbol-package symbol)))
2472    "True if SYMBOL is external in PACKAGE.    "True if SYMBOL is external in PACKAGE.
2473  If PACKAGE is not specified, the home package of SYMBOL is used."  If PACKAGE is not specified, the home package of SYMBOL is used."
2474    (unless package    (and package
2475      (setq package (symbol-package symbol)))         (eq (nth-value 1 (find-symbol (symbol-name symbol) package))
2476    (when package             :external)))
2477      (multiple-value-bind (_ status)  
         (find-symbol (symbol-name symbol) package)  
       (declare (ignore _))  
       (eq status :external))))  
   
2478  (defun find-matching-packages (name matcher)  (defun find-matching-packages (name matcher)
2479    "Return a list of package names matching NAME with MATCHER.    "Return a list of package names matching NAME with MATCHER.
2480  MATCHER is a two-argument predicate."  MATCHER is a two-argument predicate."

Legend:
Removed from v.1.329  
changed lines
  Added in v.1.330

  ViewVC Help
Powered by ViewVC 1.1.5