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

Diff of /slime/swank.lisp

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

revision 1.146 by wjenkner, Fri Mar 12 05:35:35 2004 UTC revision 1.147 by heller, Fri Mar 12 21:11:57 2004 UTC
# Line 14  Line 14 
14             #:start-server             #:start-server
15             #:create-swank-server             #:create-swank-server
16             #:ed-in-emacs             #:ed-in-emacs
17               ;; re-exported from backend
18             #:frame-source-location-for-emacs             #:frame-source-location-for-emacs
19             #:restart-frame             #:restart-frame
            #:return-from-frame  
20             #:profiled-functions             #:profiled-functions
21             #:profile-report             #:profile-report
22             #:profile-reset             #:profile-reset
# Line 410  element." Line 410  element."
410       (encode-message `(:read-aborted ,(drop-thread thread) ,@args) socket-io))       (encode-message `(:read-aborted ,(drop-thread thread) ,@args) socket-io))
411      ((:emacs-return-string thread tag string)      ((:emacs-return-string thread tag string)
412       (send (lookup-thread-id thread) `(take-input ,tag ,string)))       (send (lookup-thread-id thread) `(take-input ,tag ,string)))
413      (((:read-output :new-package :new-features :ed)      (((:read-output :new-package :new-features :ed :%apply)
414        &rest _)        &rest _)
415       (declare (ignore _))       (declare (ignore _))
416       (encode-message event socket-io))))       (encode-message event socket-io))))
# Line 538  element." Line 538  element."
538        ((:return thread &rest args)        ((:return thread &rest args)
539         (declare (ignore thread))         (declare (ignore thread))
540         (send `(:return ,@args)))         (send `(:return ,@args)))
541        (((:read-output :new-package :new-features :ed :debug-condition)        (((:read-output :new-package :new-features :debug-condition :ed :%apply)
542          &rest _)          &rest _)
543         (declare (ignore _))         (declare (ignore _))
544         (send event)))))         (send event)))))
# Line 669  If a protocol error occurs then a SLIME- Line 669  If a protocol error occurs then a SLIME-
669                             *read-input-catch-tag*)))))))                             *read-input-catch-tag*)))))))
670    
671  (defslimefun take-input (tag input)  (defslimefun take-input (tag input)
672      "Return the string INPUT to the continuation TAG."
673    (throw tag input))    (throw tag input))
674    
675  (defslimefun connection-info ()  (defslimefun connection-info ()
# Line 738  exists." Line 739  exists."
739            (t (error "Unknown symbol: ~S [in ~A]" string default-package)))))            (t (error "Unknown symbol: ~S [in ~A]" string default-package)))))
740    
741  (defslimefun arglist-string (name)  (defslimefun arglist-string (name)
742      "Return the arglist for NAME as a string.
743    NAME is a string.  The starts and ends with parens."
744    (multiple-value-bind (arglist condition)    (multiple-value-bind (arglist condition)
745        (ignore-errors (values (arglist (find-symbol-or-lose name))))        (ignore-errors (values (arglist (find-symbol-or-lose name))))
746      (cond (condition (format nil "(-- ~A)" condition))      (cond (condition (format nil "(-- ~A)" condition))
# Line 751  exists." Line 754  exists."
754      (print-arglist arglist)))      (print-arglist arglist)))
755    
756  (defun print-arglist (arglist)  (defun print-arglist (arglist)
757      "Print the list ARGLIST for display in the echo area.
758    The argument name are printed without package qualifiers and
759    pretty printing of (function foo) as #'foo is suppressed."
760    (with-standard-io-syntax    (with-standard-io-syntax
761      (let ((*print-case* :downcase)      (let ((*print-case* :downcase)
762            (*print-pretty* t)            (*print-pretty* t)
# Line 794  exists." Line 800  exists."
800  (defvar *sldb-initial-frames* 20  (defvar *sldb-initial-frames* 20
801    "The initial number of backtrace frames to send to Emacs.")    "The initial number of backtrace frames to send to Emacs.")
802    
803  (defvar *sldb-restarts*)  (defvar *sldb-restarts* nil
804      "The list of currenlty active restarts.")
805    
806  (defun swank-debugger-hook (condition hook)  (defun swank-debugger-hook (condition hook)
807    "Debugger entry point, called from *DEBUGGER-HOOK*.    "Debugger entry point, called from *DEBUGGER-HOOK*.
# Line 828  after Emacs causes a restart to be invok Line 835  after Emacs causes a restart to be invok
835                       (read-from-emacs))))))                       (read-from-emacs))))))
836      (send-to-emacs `(:debug-return ,(current-thread) ,level))))      (send-to-emacs `(:debug-return ,(current-thread) ,level))))
837    
838  (defun sldb-break-with-default-debugger ()  (defslimefun sldb-break-with-default-debugger ()
839      "Invoke the default debugger by returning from our debugger-loop."
840    (throw 'sldb-enter-default-debugger nil))    (throw 'sldb-enter-default-debugger nil))
841    
842  (defun handle-sldb-condition (condition)  (defun handle-sldb-condition (condition)
# Line 843  conditions are simply reported." Line 851  conditions are simply reported."
851  (defun safe-condition-message (condition)  (defun safe-condition-message (condition)
852    "Safely print condition to a string, handling any errors during    "Safely print condition to a string, handling any errors during
853  printing."  printing."
854    (handler-case    (let ((*print-pretty* t))
855        (princ-to-string condition)      (handler-case
856      (error (cond)          (princ-to-string condition)
857        ;; Beware of recursive errors in printing, so only use the condition        (error (cond)
858        ;; if it is printable itself:          ;; Beware of recursive errors in printing, so only use the condition
859        (format nil "Unable to display error condition~@[: ~A~]"          ;; if it is printable itself:
860                (ignore-errors (princ-to-string cond))))))          (format nil "Unable to display error condition~@[: ~A~]"
861                    (ignore-errors (princ-to-string cond)))))))
862    
863  (defun debugger-condition-for-emacs ()  (defun debugger-condition-for-emacs ()
864    (list (safe-condition-message *swank-debugger-condition*)    (list (safe-condition-message *swank-debugger-condition*)
# Line 873  format suitable for Emacs." Line 882  format suitable for Emacs."
882      (subseq string (length label))))      (subseq string (length label))))
883    
884  (defslimefun backtrace (start end)  (defslimefun backtrace (start end)
885      "Return a list ((I FRAME) ...) of frames from START to END.
886    I is an integer describing and FRAME a string."
887    (loop for frame in (compute-backtrace start end)    (loop for frame in (compute-backtrace start end)
888          for i from start          for i from start
889          collect (list i (frame-for-emacs i frame))))          collect (list i (frame-for-emacs i frame))))
# Line 937  has changed, ignore the request." Line 948  has changed, ignore the request."
948     (multiple-value-list     (multiple-value-list
949      (eval-in-frame index (from-string string)))))      (eval-in-frame index (from-string string)))))
950    
951  (defslimefun frame-locals-for-emacs (frame-index)  (defslimefun frame-locals-for-emacs (index)
952      "Return a property list ((&key NAME ID VALUE) ...) describing
953    the local variables in the frame INDEX."
954    (let ((*print-readably* nil)    (let ((*print-readably* nil)
955          (*print-pretty* t)          (*print-pretty* t)
956          (*print-circle* t))          (*print-circle* t))
# Line 945  has changed, ignore the request." Line 958  has changed, ignore the request."
958                (destructuring-bind (&key name id value) frame-locals                (destructuring-bind (&key name id value) frame-locals
959                  (list :name (to-string name) :id id                  (list :name (to-string name) :id id
960                        :value (to-string value))))                        :value (to-string value))))
961              (frame-locals frame-index))))              (frame-locals index))))
962    
963  (defslimefun frame-catch-tags-for-emacs (frame-index)  (defslimefun frame-catch-tags-for-emacs (frame-index)
964    (frame-catch-tags frame-index))    (mapcar #'to-string (frame-catch-tags frame-index)))
965    
966  (defslimefun sldb-disassemble (index)  (defslimefun sldb-disassemble (index)
967    (with-output-to-string (*standard-output*)    (with-output-to-string (*standard-output*)
968      (disassemble-frame index)))      (disassemble-frame index)))
969    
970    (defslimefun sldb-return-from-frame (index string)
971      (let ((form (from-string string)))
972        (to-string (multiple-value-list (return-from-frame index form)))))
973    
974    
975  ;;;; Evaluation  ;;;; Evaluation
976    
# Line 963  has changed, ignore the request." Line 980  has changed, ignore the request."
980      (send-to-emacs `(:%apply ,(string-downcase (string fn)) ,args))))      (send-to-emacs `(:%apply ,(string-downcase (string fn)) ,args))))
981    
982  (defslimefun eval-string (string buffer-package id)  (defslimefun eval-string (string buffer-package id)
983      "Read and evaluate STRING in BUFFER-PACKAGE.
984    Return the result values as a list to strings to the continuation ID.
985    Errors are trapped and invoke our debugger."
986    (let ((*debugger-hook* #'swank-debugger-hook))    (let ((*debugger-hook* #'swank-debugger-hook))
987      (let (ok result)      (let (ok result)
988        (unwind-protect        (unwind-protect
# Line 1073  change, then send Emacs an update." Line 1093  change, then send Emacs an update."
1093      (list (package-name p) (shortest-package-nickname p))))      (list (package-name p) (shortest-package-nickname p))))
1094    
1095  (defslimefun set-default-directory (directory)  (defslimefun set-default-directory (directory)
1096    (setf *default-pathname-defaults* (merge-pathnames directory))    (setf *default-pathname-defaults* (truename (merge-pathnames directory)))
1097    (namestring *default-pathname-defaults*))    (namestring *default-pathname-defaults*))
1098    
1099  (defslimefun listener-eval (string)  (defslimefun listener-eval (string)
# Line 1093  WHAT can be a filename (pathname or stri Line 1113  WHAT can be a filename (pathname or stri
1113    (send-oob-to-emacs `(:ed ,(if (pathnamep what)    (send-oob-to-emacs `(:ed ,(if (pathnamep what)
1114                                  (canonicalize-filename what)                                  (canonicalize-filename what)
1115                                  what))))                                  what))))
   
1116    
1117  ;;;; Compilation Commands.  ;;;; Compilation Commands.
1118    
# Line 1436  that symbols accessible in the current p Line 1455  that symbols accessible in the current p
1455      (describe-to-string (or (macro-function symbol)      (describe-to-string (or (macro-function symbol)
1456                              (symbol-function symbol)))))                              (symbol-function symbol)))))
1457    
1458  (defslimefun describe-definition-for-emacs (symbol-name kind)  (defslimefun describe-definition-for-emacs (name kind)
1459    (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name)    (with-output-to-string (*standard-output*)
1460      (cond (foundp      (describe-definition (find-symbol-or-lose name) kind)))
            (with-output-to-string (*standard-output*)  
                (describe-definition symbol kind)))  
           (t  
            (format nil "Unknown symbol: ~S [in ~A]"  
                    symbol-name *buffer-package*)))))  
1461    
1462  (defslimefun documentation-symbol (symbol-name &optional default)  (defslimefun documentation-symbol (symbol-name &optional default)
1463    (let ((*package* *buffer-package*))    (let ((*package* *buffer-package*))
# Line 1503  that symbols accessible in the current p Line 1517  that symbols accessible in the current p
1517    
1518  ;;;; Source Locations  ;;;; Source Locations
1519    
1520  (defslimefun find-definitions-for-emacs (symbol-name)  (defslimefun find-definitions-for-emacs (name)
1521    (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name)    "Return a list ((DSPEC LOCATION) ...) of definitions for NAME.
1522      (cond ((not foundp) '())  DSPEC is a string and LOCATION a source location. NAME is a string."
1523            (t (loop for (dspec loc) in (find-definitions symbol)    (multiple-value-bind (sexp error)
1524          (ignore-errors (values (from-string name)))
1525        (cond (error ())
1526              (t (loop for (dspec loc) in (find-definitions sexp)
1527                     collect (list (to-string dspec) loc))))))                     collect (list (to-string dspec) loc))))))
1528    
1529  (defun alistify (list key test)  (defun alistify (list key test)
1530    "Partition the elements of LIST into an alist.  KEY extracts the key    "Partition the elements of LIST into an alist.  KEY extracts the key
1531  from an element and TEST is used to compare keys."  from an element and TEST is used to compare keys."
# Line 1549  from an element and TEST is used to comp Line 1566  from an element and TEST is used to comp
1566    (location-buffer (xref.location xref)))    (location-buffer (xref.location xref)))
1567    
1568  (defun group-xrefs (xrefs)  (defun group-xrefs (xrefs)
1569      "Group XREFS, a list of the form ((DSPEC LOCATION) ...) by location.
1570    The result is a list of the form ((LOCATION . ((DSPEC . LOCATION) ...)) ...)."
1571    (multiple-value-bind (resolved errors)    (multiple-value-bind (resolved errors)
1572        (partition xrefs #'location-valid-p #'xref.location)        (partition xrefs #'location-valid-p #'xref.location)
1573      (let ((alist (alistify resolved #'xref-buffer #'equal)))      (let ((alist (alistify resolved #'xref-buffer #'equal)))

Legend:
Removed from v.1.146  
changed lines
  Added in v.1.147

  ViewVC Help
Powered by ViewVC 1.1.5