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

Diff of /slime/swank-cmucl.lisp

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

revision 1.12 by lgorrie, Sat Oct 25 01:54:00 2003 UTC revision 1.12.2.1 by lgorrie, Mon Oct 27 04:04:56 2003 UTC
# Line 1  Line 1 
1    
2  (declaim (optimize debug))  (declaim (optimize debug))
3    
4  (in-package :swank)  (eval-when (:compile-toplevel :load-toplevel :execute)
5      (defpackage :swank-cmucl
6        (:use :common-lisp)
7        (:nicknames "SWANK-BACKEND")))
8    
9    (in-package :swank-cmucl)
10    
11    (import '(swank:*swank-debugger-condition* swank:*sldb-level*
12    swank:*buffer-package* swank:*compiler-notes* swank:*notes-database*
13    swank:*previous-compiler-condition* swank:*previous-context*
14    swank:*sldb-level* swank:*swank-debugger-condition*
15    swank:apply-macro-expander swank:backtrace-for-emacs
16    swank:call-with-compilation-hooks swank:clear-note-database
17    swank:from-string swank:print-description-to-string swank:to-string
18    swank:*emacs-io* swank:*slime-output* swank:*slime-input* swank:*slime-io*))
19    
20    
21  ;;; Setup and hooks.  ;;; Setup and hooks.
22    
# Line 29  Line 44 
44       (unless (zerop (lisp::string-output-stream-index stream))       (unless (zerop (lisp::string-output-stream-index stream))
45         (setf (slime-output-stream-last-charpos stream)         (setf (slime-output-stream-last-charpos stream)
46               (slime-out-misc stream :charpos))               (slime-out-misc stream :charpos))
47         (send-to-emacs `(:read-output ,(get-output-stream-string stream)))))         (swank:send-to-emacs `(:read-output ,(get-output-stream-string stream)))))
48      (:file-position nil)      (:file-position nil)
49      (:charpos      (:charpos
50       (do ((index (1- (the fixnum (lisp::string-output-stream-index stream)))       (do ((index (1- (the fixnum (lisp::string-output-stream-index stream)))
# Line 57  Line 72 
72    
73  (defun slime-input-stream/n-bin (stream buffer start requested eof-errorp)  (defun slime-input-stream/n-bin (stream buffer start requested eof-errorp)
74    (let ((*read-input-catch-tag* (1+ *read-input-catch-tag*)))    (let ((*read-input-catch-tag* (1+ *read-input-catch-tag*)))
75      (send-to-emacs `(:read-input ,requested ,*read-input-catch-tag*))      (swank:send-to-emacs `(:read-input ,requested ,*read-input-catch-tag*))
76      (let ((input (catch *read-input-catch-tag*      (let ((input (catch *read-input-catch-tag*
77                     (read-from-emacs))))                     (swank:read-from-emacs))))
78        (loop for c across input        (loop for c across input
79              for i from start              for i from start
80              do (setf (aref buffer i) (char-code c)))              do (setf (aref buffer i) (char-code c)))
81        (length input))))        (length input))))
82    
83  (defslimefun take-input (tag input)  (defun swank:take-input (tag input)
84    (throw tag input))    (throw tag input))
85    
86  (defun create-swank-server (port &key reuse-address (address "localhost"))  (defun swank:create-swank-server (port &key reuse-address (address "localhost"))
87    "Create a SWANK TCP server."    "Create a SWANK TCP server."
88      (dribble "/tmp/swank.log")
89    (let* ((hostent (ext:lookup-host-entry address))    (let* ((hostent (ext:lookup-host-entry address))
90           (address (car (ext:host-entry-addr-list hostent)))           (address (car (ext:host-entry-addr-list hostent)))
91           (ip (ext:htonl address)))           (ip (ext:htonl address)))
# Line 103  Line 119 
119  The request is read from the socket as a sexp and then evaluated."  The request is read from the socket as a sexp and then evaluated."
120    (let ((completed nil))    (let ((completed nil))
121      (let ((condition (catch 'serve-request-catcher      (let ((condition (catch 'serve-request-catcher
122                         (read-from-emacs)                         (swank:read-from-emacs)
123                         (setq completed t))))                         (setq completed t))))
124        (unless completed        (unless completed
125          (when *swank-debug-p*          (when swank:*swank-debug-p*
126            (format *debug-io*            (format *debug-io*
127                    "~&;; Connection to Emacs lost.~%;; [~A]~%" condition))                    "~&;; Connection to Emacs lost.~%;; [~A]~%" condition))
128          (sys:invalidate-descriptor (sys:fd-stream-fd *emacs-io*))          (sys:invalidate-descriptor (sys:fd-stream-fd *emacs-io*))
# Line 114  The request is read from the socket as a Line 130  The request is read from the socket as a
130    
131  ;;;  ;;;
132    
133  (defslimefun set-default-directory (directory)  (defun swank:set-default-directory (directory)
134    (setf (ext:default-directory) (namestring directory))    (setf (ext:default-directory) (namestring directory))
135    ;; Setting *default-pathname-defaults* to an absolute directory    ;; Setting *default-pathname-defaults* to an absolute directory
136    ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.    ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
# Line 198  compiler state." Line 214  compiler state."
214           (reverse           (reverse
215            (c::compiler-error-context-original-source-path context)))))            (c::compiler-error-context-original-source-path context)))))
216    
217  (defun call-trapping-compilation-notes (fn)  (defun swank:call-trapping-compilation-notes (fn)
218    (handler-bind ((c::compiler-error #'handle-notification-condition)    (handler-bind ((c::compiler-error #'handle-notification-condition)
219                   (c::style-warning #'handle-notification-condition)                   (c::style-warning #'handle-notification-condition)
220                   (c::warning #'handle-notification-condition))                   (c::warning #'handle-notification-condition))
221      (funcall fn)))      (funcall fn)))
222    
223  (defslimefun swank-compile-file (filename load)  (defun swank:swank-compile-file (filename load)
224    (call-with-compilation-hooks    (call-with-compilation-hooks
225     (lambda ()     (lambda ()
226       (clear-note-database filename)       (clear-note-database filename)
# Line 213  compiler state." Line 229  compiler state."
229             (*buffer-offset* nil))             (*buffer-offset* nil))
230         (compile-file filename :load load)))))         (compile-file filename :load load)))))
231    
232  (defslimefun swank-compile-string (string buffer start)  (defun swank:swank-compile-string (string buffer start)
233    (call-with-compilation-hooks    (call-with-compilation-hooks
234     (lambda ()     (lambda ()
235       (let ((*package* *buffer-package*)       (let ((*package* *buffer-package*)
# Line 254  This is a workaround for a CMUCL bug: XR Line 270  This is a workaround for a CMUCL bug: XR
270  (defun unix-truename (pathname)  (defun unix-truename (pathname)
271    (ext:unix-namestring (truename pathname)))    (ext:unix-namestring (truename pathname)))
272    
273  (defslimefun arglist-string (fname)  (defun swank:arglist-string (fname)
274    "Return a string describing the argument list for FNAME.    "Return a string describing the argument list for FNAME.
275  The result has the format \"(...)\"."  The result has the format \"(...)\"."
276    (declare (type string fname))    (declare (type string fname))
277    (multiple-value-bind (function condition)    (multiple-value-bind (function condition)
278        (ignore-errors (values (from-string fname)))        (ignore-errors (values (from-string fname)))
279      (when condition      (when condition
280        (return-from arglist-string (format nil "(-- ~A)" condition)))        (return-from swank:arglist-string (format nil "(-- ~A)" condition)))
281      (let ((arglist      (let ((arglist
282             (if (not (or (fboundp function)             (if (not (or (fboundp function)
283                          (functionp function)))                          (functionp function)))
# Line 287  The result has the format \"(...)\"." Line 303  The result has the format \"(...)\"."
303            arglist            arglist
304            (to-string arglist)))))            (to-string arglist)))))
305    
306  (defslimefun who-calls (function-name)  (defun swank:who-calls (function-name)
307    "Return the places where FUNCTION-NAME is called."    "Return the places where FUNCTION-NAME is called."
308    (xref-results-for-emacs (xref:who-calls function-name)))    (xref-results-for-emacs (xref:who-calls function-name)))
309    
310  (defslimefun who-references (variable)  (defun swank:who-references (variable)
311    "Return the places where the global variable VARIABLE is referenced."    "Return the places where the global variable VARIABLE is referenced."
312    (xref-results-for-emacs (xref:who-references variable)))    (xref-results-for-emacs (xref:who-references variable)))
313    
314  (defslimefun who-binds (variable)  (defun swank:who-binds (variable)
315    "Return the places where the global variable VARIABLE is bound."    "Return the places where the global variable VARIABLE is bound."
316    (xref-results-for-emacs (xref:who-binds variable)))    (xref-results-for-emacs (xref:who-binds variable)))
317    
318  (defslimefun who-sets (variable)  (defun swank:who-sets (variable)
319    "Return the places where the global variable VARIABLE is set."    "Return the places where the global variable VARIABLE is set."
320    (xref-results-for-emacs (xref:who-sets variable)))    (xref-results-for-emacs (xref:who-sets variable)))
321    
322  #+cmu19  #+cmu19
323  (defslimefun who-macroexpands (macro)  (defun swank:who-macroexpands (macro)
324    "Return the places where MACRO is expanded."    "Return the places where MACRO is expanded."
325    (xref-results-for-emacs (xref:who-macroexpands macro)))    (xref-results-for-emacs (xref:who-macroexpands macro)))
326    
# Line 421  constant pool." Line 437  constant pool."
437    (let ((*print-pretty* nil))    (let ((*print-pretty* nil))
438      (mapcar #'to-string (remove-if-not #'ext:valid-function-name-p list))))      (mapcar #'to-string (remove-if-not #'ext:valid-function-name-p list))))
439    
440  (defslimefun list-callers (symbol-name)  (defun swank:list-callers (symbol-name)
441    (stringify-function-name-list (function-callers (from-string symbol-name))))    (stringify-function-name-list (function-callers (from-string symbol-name))))
442    
443  (defslimefun list-callees (symbol-name)  (defun swank:list-callees (symbol-name)
444    (stringify-function-name-list (function-callees (from-string symbol-name))))    (stringify-function-name-list (function-callees (from-string symbol-name))))
445    
446  ;;;; Definitions  ;;;; Definitions
# Line 492  This is useful when debugging the defini Line 508  This is useful when debugging the defini
508             (when location             (when location
509               (source-location-for-emacs location))))))               (source-location-for-emacs location))))))
510    
511  (defslimefun function-source-location-for-emacs (fname)  (defun swank:function-source-location-for-emacs (fname)
512    "Return the source-location of FNAME's definition."    "Return the source-location of FNAME's definition."
513    (let* ((fname (from-string fname))    (let* ((fname (from-string fname))
514           (finder           (finder
# Line 545  Return NIL if the symbol is unbound." Line 561  Return NIL if the symbol is unbound."
561        (if result        (if result
562            (list* :designator (to-string symbol) result)))))            (list* :designator (to-string symbol) result)))))
563    
564  (defslimefun describe-setf-function (symbol-name)  (defun swank:describe-setf-function (symbol-name)
565    (print-description-to-string    (print-description-to-string
566     (or (ext:info setf inverse (from-string symbol-name))     (or (ext:info setf inverse (from-string symbol-name))
567         (ext:info setf expander (from-string symbol-name)))))         (ext:info setf expander (from-string symbol-name)))))
568    
569  (defslimefun describe-type (symbol-name)  (defun swank:describe-type (symbol-name)
570    (print-description-to-string    (print-description-to-string
571     (kernel:values-specifier-type (from-string symbol-name))))     (kernel:values-specifier-type (from-string symbol-name))))
572    
573  (defslimefun describe-class (symbol-name)  (defun swank:describe-class (symbol-name)
574    (print-description-to-string (find-class (from-string symbol-name) nil)))    (print-description-to-string (find-class (from-string symbol-name) nil)))
575    
576  ;;; Macroexpansion  ;;; Macroexpansion
577    
578  (defslimefun swank-macroexpand-all (string)  (defun swank:swank-macroexpand-all (string)
579    (apply-macro-expander #'walker:macroexpand-all string))    (apply-macro-expander #'walker:macroexpand-all string))
580    
581    
# Line 569  Return NIL if the symbol is unbound." Line 585  Return NIL if the symbol is unbound."
585    (gethash (debug::trace-fdefinition fname)    (gethash (debug::trace-fdefinition fname)
586             debug::*traced-functions*))             debug::*traced-functions*))
587    
588  (defslimefun toggle-trace-fdefinition (fname-string)  (defun swank:toggle-trace-fdefinition (fname-string)
589    (let ((fname (from-string fname-string)))    (let ((fname (from-string fname-string)))
590      (cond ((tracedp fname)      (cond ((tracedp fname)
591             (debug::untrace-1 fname)             (debug::untrace-1 fname)
# Line 581  Return NIL if the symbol is unbound." Line 597  Return NIL if the symbol is unbound."
597    
598  ;;; Debugging  ;;; Debugging
599    
 (defvar *sldb-level* 0)  
600  (defvar *sldb-stack-top*)  (defvar *sldb-stack-top*)
601  (defvar *sldb-restarts*)  (defvar *sldb-restarts*)
602    
603  (defslimefun getpid ()  (defun swank:getpid ()
604    (unix:unix-getpid))    (unix:unix-getpid))
605    
606  (defslimefun sldb-loop ()  (defun swank:call-with-debugging-environment (function)
607      (unix:unix-sigsetmask 0)
608      (let ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame)))
609            (*sldb-restarts* (compute-restarts swank:*swank-debugger-condition*))
610            (debug:*stack-top-hint* nil)
611            (*readtable* (or debug:*debug-readtable* *readtable*))
612            (*print-level* debug:*debug-print-level*)
613            (*print-length* debug:*debug-print-length*))
614        (handler-bind ((di:debug-condition
615                        (lambda (condition)
616                          (signal 'swank-debug-condition
617                                  :wrapped-condition condition))))
618          (funcall function))))
619    
620    #+nil
621    (defun swank:sldb-loop ()
622    (unix:unix-sigsetmask 0)    (unix:unix-sigsetmask 0)
623    (let* ((*sldb-level* (1+ *sldb-level*))    (let* ((*sldb-level* (1+ *sldb-level*))
624           (*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame)))           (*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame)))
# Line 600  Return NIL if the symbol is unbound." Line 630  Return NIL if the symbol is unbound."
630           (*readtable* (or debug:*debug-readtable* *readtable*))           (*readtable* (or debug:*debug-readtable* *readtable*))
631           (*print-level* debug:*debug-print-level*)           (*print-level* debug:*debug-print-level*)
632           (*print-length* debug:*debug-print-length*))           (*print-length* debug:*debug-print-length*))
633      (send-to-emacs (list* :debug *sldb-level* (debugger-info-for-emacs 0 1)))      (swank:send-to-emacs
634         (list* :debug *sldb-level* (debugger-info-for-emacs 0 1)))
635      (handler-bind ((di:debug-condition      (handler-bind ((di:debug-condition
636                      (lambda (condition)                      (lambda (condition)
637                        (send-to-emacs `(:debug-condition                        (swank:send-to-emacs `(:debug-condition
638                                         ,(princ-to-string condition)))                                         ,(princ-to-string condition)))
639                        (throw 'sldb-loop-catcher nil))))                        (throw 'sldb-loop-catcher nil))))
640        (unwind-protect        (unwind-protect
641             (loop             (loop
642              (catch 'sldb-loop-catcher              (catch 'sldb-loop-catcher
643                (with-simple-restart (abort "Return to sldb level ~D." level)                (with-simple-restart (abort "Return to sldb level ~D." level)
644                  (read-from-emacs))))                  (swank:read-from-emacs))))
645          (send-to-emacs `(:debug-return ,level))))))          (swank:send-to-emacs `(:debug-return ,level))))))
646    
647  (defun format-restarts-for-emacs ()  (defun format-restarts-for-emacs ()
648    "Return a list of restarts for *swank-debugger-condition* in a    "Return a list of restarts for *swank-debugger-condition* in a
# Line 631  format suitable for Emacs." Line 662  format suitable for Emacs."
662        ((zerop i) frame)))        ((zerop i) frame)))
663    
664  (defun nth-restart (index)  (defun nth-restart (index)
665    (nth index *sldb-restarts*))    (or (nth index *sldb-restarts*)
666          (signal 'swank-debug-condition
667                  :wrapped-condition
668                  (make-condition 'simple-condition
669                                  :format-control "Restart out of bounds: ~S"
670                                  :format-arguments (list index)))))
671    
672  (defun format-frame-for-emacs (frame)  (defun format-frame-for-emacs (frame)
673    (list (di:frame-number frame)    (list (di:frame-number frame)
# Line 655  stack." Line 691  stack."
691            while f            while f
692            collect f)))            collect f)))
693    
694  (defslimefun backtrace-for-emacs (start end)  (defun swank:backtrace-for-emacs (start end)
695    (mapcar #'format-frame-for-emacs (compute-backtrace start end)))    (mapcar #'format-frame-for-emacs (compute-backtrace start end)))
696    
697  (defslimefun debugger-info-for-emacs (start end)  (defun swank:debugger-info-for-emacs (start end)
698    (list (format-condition-for-emacs)    (list (format-condition-for-emacs)
699          (format-restarts-for-emacs)          (format-restarts-for-emacs)
700          (backtrace-length)          (backtrace-length)
# Line 716  stack." Line 752  stack."
752    (handler-case (source-location-for-emacs code-location)    (handler-case (source-location-for-emacs code-location)
753      (t (c) (list :error (debug::safe-condition-message c)))))      (t (c) (list :error (debug::safe-condition-message c)))))
754    
755  (defslimefun frame-source-location-for-emacs (index)  (defun swank:frame-source-location-for-emacs (index)
756    (safe-source-location-for-emacs (di:frame-code-location (nth-frame index))))    (safe-source-location-for-emacs (di:frame-code-location (nth-frame index))))
757    
758  (defslimefun eval-string-in-frame (string index)  (defun swank:eval-string-in-frame (string index)
759    (to-string (di:eval-in-frame (nth-frame index) (from-string string))))    (to-string (di:eval-in-frame (nth-frame index) (from-string string))))
760    
761  (defslimefun frame-locals (index)  (defun swank:frame-locals (index)
762    (let* ((frame (nth-frame index))    (let* ((frame (nth-frame index))
763           (location (di:frame-code-location frame))           (location (di:frame-code-location frame))
764           (debug-function (di:frame-debug-function frame))           (debug-function (di:frame-debug-function frame))
# Line 738  stack." Line 774  stack."
774                         (to-string (di:debug-variable-value v frame))                         (to-string (di:debug-variable-value v frame))
775                         "<not-available>")))))                         "<not-available>")))))
776    
777  (defslimefun frame-catch-tags (index)  (defun swank:frame-catch-tags (index)
778    (loop for (tag . code-location) in (di:frame-catches (nth-frame index))    (loop for (tag . code-location) in (di:frame-catches (nth-frame index))
779          collect `(,tag . ,(safe-source-location-for-emacs code-location))))          collect `(,tag . ,(safe-source-location-for-emacs code-location))))
780    
781  (defslimefun invoke-nth-restart (index)  (defun swank:invoke-nth-restart (sldb-level index)
782    (invoke-restart (nth-restart index)))    (when (eql sldb-level *sldb-level*)
783        (invoke-restart (nth-restart index))))
784    
785  (defslimefun sldb-continue ()  (defun swank:sldb-continue ()
786    (continue *swank-debugger-condition*))    (continue *swank-debugger-condition*))
787    
788  (defslimefun sldb-abort ()  (defun swank:sldb-abort ()
789    (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))    (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
790    
791  (defslimefun throw-to-toplevel ()  (defun swank:throw-to-toplevel ()
792    (throw 'lisp::top-level-catcher nil))    (throw 'lisp::top-level-catcher nil))
793    
794    
# Line 769  stack." Line 806  stack."
806    (setq *inspector-stack* nil)    (setq *inspector-stack* nil)
807    (setf (fill-pointer *inspector-history*) 0))    (setf (fill-pointer *inspector-history*) 0))
808    
809  (defslimefun init-inspector (string)  (defun swank:init-inspector (string)
810    (reset-inspector)    (reset-inspector)
811    (inspect-object (eval (from-string string))))    (inspect-object (eval (from-string string))))
812    
# Line 836  stack." Line 873  stack."
873  (defun nth-part (index)  (defun nth-part (index)
874    (cdr (nth index *inspectee-parts*)))    (cdr (nth index *inspectee-parts*)))
875    
876  (defslimefun inspect-nth-part (index)  (defun swank:inspect-nth-part (index)
877    (inspect-object (nth-part index)))    (inspect-object (nth-part index)))
878    
879  (defslimefun inspector-pop ()  (defun swank:inspector-pop ()
880    "Drop the inspector stack and inspect the second element.  Return    "Drop the inspector stack and inspect the second element.  Return
881  nil if there's no second element."  nil if there's no second element."
882    (cond ((cdr *inspector-stack*)    (cond ((cdr *inspector-stack*)
# Line 847  nil if there's no second element." Line 884  nil if there's no second element."
884           (inspect-object (pop *inspector-stack*)))           (inspect-object (pop *inspector-stack*)))
885          (t nil)))          (t nil)))
886    
887  (defslimefun inspector-next ()  (defun swank:inspector-next ()
888    "Inspect the next element in the *inspector-history*."    "Inspect the next element in the *inspector-history*."
889    (let ((position (position *inspectee* *inspector-history*)))    (let ((position (position *inspectee* *inspector-history*)))
890      (cond ((= (1+ position) (length *inspector-history*))      (cond ((= (1+ position) (length *inspector-history*))
891             nil)             nil)
892            (t (inspect-object (aref *inspector-history* (1+ position)))))))            (t (inspect-object (aref *inspector-history* (1+ position)))))))
893    
894  (defslimefun quit-inspector ()  (defun swank:quit-inspector ()
895    (reset-inspector)    (reset-inspector)
896    nil)    nil)
897    
898  (defslimefun describe-inspectee ()  (defun swank:describe-inspectee ()
899    "Describe the currently inspected object."    "Describe the currently inspected object."
900    (print-description-to-string *inspectee*))    (print-description-to-string *inspectee*))
901    

Legend:
Removed from v.1.12  
changed lines
  Added in v.1.12.2.1

  ViewVC Help
Powered by ViewVC 1.1.5