/[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.32 by heller, Wed Dec 3 22:34:50 2003 UTC revision 1.51 by heller, Fri Jan 16 21:49:29 2004 UTC
# Line 4  Line 4 
4    
5  (in-package :swank)  (in-package :swank)
6    
 ;; Turn on xref. [should we?]  
 (setf c:*record-xref-info* t)  
   
7  (defun without-interrupts* (body)  (defun without-interrupts* (body)
8    (sys:without-interrupts (funcall body)))    (sys:without-interrupts (funcall body)))
9    
 (defun set-fd-non-blocking (fd)  
   (flet ((fcntl (fd cmd arg)  
            (multiple-value-bind (flags errno) (unix:unix-fcntl fd cmd arg)  
              (or flags  
                  (error "fcntl: ~A" (unix:get-unix-error-msg errno))))))  
     (let ((flags (fcntl fd unix:F-GETFL 0)))  
       (fcntl fd unix:F-SETFL (logior flags unix:O_NONBLOCK)))))  
   
10    
11  ;;;; TCP server.  ;;;; TCP server.
12    
13  (defun resolve-hostname (name)  (setq *swank-in-background* :fd-handler)
14    (let* ((hostent (ext:lookup-host-entry name))  
15    (defmethod create-socket (port)
16      (let ((fd (ext:create-inet-listener port :stream
17                                          :reuse-address t
18                                          :host (resolve-hostname "localhost"))))
19        #+MP
20        (when *multiprocessing-enabled*
21          (set-fd-non-blocking fd))
22        fd))
23    
24    (defmethod local-port (socket)
25      (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket))))
26    
27    (defmethod close-socket (socket)
28      (ext:close-socket (socket-fd socket)))
29    
30    (defmethod accept-connection (socket)
31      #+MP (when *multiprocessing-enabled* (mp:process-wait-until-fd-usable socket :input))
32      (make-socket-io-stream (ext:accept-tcp-connection socket)))
33    
34    (defmethod add-input-handler (socket fn)
35      (flet ((callback (fd)
36               (declare (ignore fd))
37               (funcall fn)))
38        (system:add-fd-handler (socket-fd socket) :input #'callback)))
39    
40    (defmethod remove-input-handlers (socket)
41      (sys:invalidate-descriptor (socket-fd socket))
42      (close socket))
43    
44    (defmethod make-fn-streams (input-fn output-fn)
45      (let* ((output (make-slime-output-stream output-fn))
46             (input  (make-slime-input-stream input-fn output)))
47        (values input output)))
48    
49    (defmethod spawn (fn &key (name "Anonymous"))
50      (mp:make-process fn :name name))
51    
52    ;;;
53    ;;;;; Socket helpers.
54    
55    (defun socket-fd (socket)
56      "Return the filedescriptor for the socket represented by SOCKET."
57      (etypecase socket
58        (fixnum socket)
59        (sys:fd-stream (sys:fd-stream-fd socket))))
60    
61    (defun resolve-hostname (hostname)
62      "Return the IP address of HOSTNAME as an integer."
63      (let* ((hostent (ext:lookup-host-entry hostname))
64           (address (car (ext:host-entry-addr-list hostent))))           (address (car (ext:host-entry-addr-list hostent))))
65      (ext:htonl address)))      (ext:htonl address)))
66    
67  (defun create-swank-server (port &key (reuse-address t)  (defun make-socket-io-stream (fd)
68                              (address "localhost"))    "Create a new input/output fd-stream for FD."
69    "Create a SWANK TCP server."    (sys:make-fd-stream fd :input t :output t :element-type 'base-char))
70    (let* ((ip (resolve-hostname address))  
71           (fd (ext:create-inet-listener port :stream  (defun set-fd-non-blocking (fd)
72                                         :reuse-address reuse-address    (flet ((fcntl (fd cmd arg)
73                                         :host ip)))             (multiple-value-bind (flags errno) (unix:unix-fcntl fd cmd arg)
74      (system:add-fd-handler fd :input #'accept-connection)               (or flags
75      (nth-value 1 (ext::get-socket-host-and-port fd))))                   (error "fcntl: ~A" (unix:get-unix-error-msg errno))))))
76        (let ((flags (fcntl fd unix:F-GETFL 0)))
77  (defun accept-connection (socket)        (fcntl fd unix:F-SETFL (logior flags unix:O_NONBLOCK)))))
   "Accept one Swank TCP connection on SOCKET and then close it."  
   (setup-request-handler (ext:accept-tcp-connection socket))  
   (sys:invalidate-descriptor socket)  
   (unix:unix-close socket))  
   
 (defun open-stream-to-emacs ()  
   "Return an output-stream to Emacs' output buffer."  
   (let* ((ip (resolve-hostname "localhost"))  
          (listener (ext:create-inet-listener 0 :stream :host ip))  
          (port (nth-value 1 (ext::get-socket-host-and-port listener))))  
     (unwind-protect  
          (progn  
            (eval-in-emacs `(slime-open-stream-to-lisp ,port))  
            (let ((fd (ext:accept-tcp-connection listener)))  
              (sys:make-fd-stream fd :output t)))  
       (ext:close-socket listener))))  
   
 (defvar *use-dedicated-output-stream* t)  
   
 (defun setup-request-handler (socket)  
   "Setup request handling for SOCKET."  
   (let* ((stream (sys:make-fd-stream socket  
                                      :input t :output t  
                                      :element-type 'base-char))  
          (input (make-slime-input-stream))  
          (output (if *use-dedicated-output-stream*  
                      (let ((*emacs-io* stream)) (open-stream-to-emacs))  
                      (make-slime-output-stream)))  
          (io (make-two-way-stream input output)))  
     (system:add-fd-handler socket  
                            :input (lambda (fd)  
                                     (declare (ignore fd))  
                                     (serve-request stream output input io)))))  
   
 (defun serve-request (*emacs-io* *slime-output* *slime-input* *slime-io*)  
   "Read and process a request from a SWANK client.  
 The request is read from the socket as a sexp and then evaluated."  
   (catch 'slime-toplevel  
     (with-simple-restart (abort "Return to Slime toplevel.")  
       (handler-case (read-from-emacs)  
         (slime-read-error (e)  
           (when *swank-debug-p*  
             (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e))  
           (sys:invalidate-descriptor (sys:fd-stream-fd *emacs-io*))  
           (close *emacs-io*)))))  
   (sys:scrub-control-stack))  
78    
79    
80  ;;;; Stream handling  ;;;; Stream handling
81    
82  (defstruct (slime-output-stream  (defstruct (slime-output-stream
83               (:include lisp::lisp-stream               (:include lisp::lisp-stream
84                         (lisp::misc #'sos/misc)                         (lisp::misc #'sos/misc)
85                         (lisp::out #'sos/out)                         (lisp::out #'sos/out)
86                         (lisp::sout #'sos/sout))                         (lisp::sout #'sos/sout))
87               (:conc-name sos.)               (:conc-name sos.)
88               (:print-function %print-slime-output-stream))               (:print-function %print-slime-output-stream)
89                 (:constructor make-slime-output-stream (output-fn)))
90      (output-fn nil :type function)
91    (buffer (make-string 512) :type string)    (buffer (make-string 512) :type string)
92    (index 0 :type kernel:index)    (index 0 :type kernel:index)
93    (column 0 :type kernel:index))    (column 0 :type kernel:index))
# Line 117  The request is read from the socket as a Line 111  The request is read from the socket as a
111  (defun sos/sout (stream string start end)  (defun sos/sout (stream string start end)
112    (loop for i from start below end    (loop for i from start below end
113          do (sos/out stream (aref string i))))          do (sos/out stream (aref string i))))
114    
115  (defun sos/misc (stream operation &optional arg1 arg2)  (defun sos/misc (stream operation &optional arg1 arg2)
116    (declare (ignore arg1 arg2))    (declare (ignore arg1 arg2))
117    (case operation    (case operation
118      ((:force-output :finish-output)      ((:force-output :finish-output)
119       (let ((end (sos.index stream)))       (let ((end (sos.index stream)))
120         (unless (zerop end)         (unless (zerop end)
121           (send-to-emacs `(:read-output ,(subseq (sos.buffer stream) 0 end)))           (funcall (sos.output-fn stream) (subseq (sos.buffer stream) 0 end))
122           (setf (sos.index stream) 0))))           (setf (sos.index stream) 0))))
123      (:charpos (sos.column stream))      (:charpos (sos.column stream))
124      (:line-length 75)      (:line-length 75)
125      (:file-position nil)      (:file-position nil)
# Line 135  The request is read from the socket as a Line 129  The request is read from the socket as a
129      (t (format *terminal-io* "~&~Astream: ~S~%" stream operation))))      (t (format *terminal-io* "~&~Astream: ~S~%" stream operation))))
130    
131  (defstruct (slime-input-stream  (defstruct (slime-input-stream
132               (:include string-stream               (:include string-stream
133                         (lisp::in #'sis/in)                         (lisp::in #'sis/in)
134                         (lisp::misc #'sis/misc))                         (lisp::misc #'sis/misc))
135               (:conc-name sis.)               (:conc-name sis.)
136               (:print-function %print-slime-output-stream))               (:print-function %print-slime-output-stream)
137    (buffer "" :type string)               (:constructor make-slime-input-stream (input-fn sos)))
138    (index 0 :type kernel:index))    (input-fn nil :type function)
139      ;; We know our sibling output stream, so that we can force it before
140      ;; requesting input.
141      (sos      nil :type slime-output-stream)
142      (buffer   ""  :type string)
143      (index    0   :type kernel:index))
144    
145  (defun sis/in (stream eof-errorp eof-value)  (defun sis/in (stream eof-errorp eof-value)
146    (declare (ignore eof-errorp eof-value))    (declare (ignore eof-errorp eof-value))
147    (let ((index (sis.index stream))    (let ((index (sis.index stream))
148          (buffer (sis.buffer stream)))          (buffer (sis.buffer stream)))
149      (when (= index (length buffer))      (when (= index (length buffer))
150        (setf buffer (slime-read-string))        (force-output (sis.sos stream))
151          (setf buffer (funcall (sis.input-fn stream)))
152        (setf (sis.buffer stream) buffer)        (setf (sis.buffer stream) buffer)
153        (setf index 0))        (setf index 0))
154      (prog1 (aref buffer index)      (prog1 (aref buffer index)
# Line 277  the error-context redundant." Line 277  the error-context redundant."
277           (make-location (list :file (namestring *compile-file-truename*))           (make-location (list :file (namestring *compile-file-truename*))
278                          (list :position 0)))                          (list :position 0)))
279          (*compile-filename*          (*compile-filename*
280             ;; XXX is this _ever_ used?  By what?  *compile-file-truename*
281             ;; should be set by the implementation inside any call to compile-file
282           (make-location (list :file *compile-filename*) (list :position 0)))           (make-location (list :file *compile-filename*) (list :position 0)))
283          (t          (t
284           (list :error "No error location available"))))           (list :error "No error location available"))))
285    
286  (defmacro with-compilation-hooks (() &body body)  (defmethod call-with-compilation-hooks (function)
287    "Execute BODY and record the set of compiler notes."    (let ((*previous-compiler-condition* nil)
288    `(let ((*previous-compiler-condition* nil)          (*previous-context* nil)
289           (*previous-context* nil)          (*print-readably* nil))
          (*print-readably* nil))  
290      (handler-bind ((c::compiler-error #'handle-notification-condition)      (handler-bind ((c::compiler-error #'handle-notification-condition)
291                     (c::style-warning  #'handle-notification-condition)                     (c::style-warning  #'handle-notification-condition)
292                     (c::warning        #'handle-notification-condition))                     (c::warning        #'handle-notification-condition))
293        ,@body)))        (funcall function))))
294    
295  (defmethod compile-file-for-emacs (filename load-p)  (defmethod compile-file-for-emacs (filename load-p)
296    (clear-xref-info filename)    (clear-xref-info filename)
297    (with-compilation-hooks ()    (with-compilation-hooks ()
298      (let ((*buffer-name* nil)      (let ((*buffer-name* nil)
299            (*compile-filename* filename))            (*compile-filename* filename))
300          (compile-file filename :load load-p))))        (multiple-value-bind (fasl-file warnings-p failure-p)
301              (compile-file filename)
302            (declare (ignore warnings-p))
303            (when (and load-p (not failure-p))
304              (load fasl-file))))))
305    
306  (defmethod compile-string-for-emacs (string &key buffer position)  (defmethod compile-string-for-emacs (string &key buffer position)
307    (with-compilation-hooks ()    (with-compilation-hooks ()
# Line 312  the error-context redundant." Line 317  the error-context redundant."
317                          :emacs-buffer-offset ,position                          :emacs-buffer-offset ,position
318                          :emacs-buffer-string ,string))))))                          :emacs-buffer-string ,string))))))
319    
320    (defmethod compile-system-for-emacs (system-name)
321      (with-compilation-hooks ()
322        (cond ((ext:featurep :asdf)
323               (let ((operate (find-symbol (string :operate) :asdf))
324                     (load-op (find-symbol (string :load-op) :asdf)))
325                 (funcall operate load-op system-name)))
326              (t (error "ASDF not loaded")))))
327    
328    
329  ;;;; XREF  ;;;; XREF
330    
# Line 380  reference   ::= (FUNCTION-SPECIFIER . SO Line 393  reference   ::= (FUNCTION-SPECIFIER . SO
393                xrefs)))                xrefs)))
394      (group-xrefs xrefs)))      (group-xrefs xrefs)))
395    
   
 (defun location-buffer= (location1 location2)  
   (equalp location1 location2))  
   
 (defun file-xrefs-for-emacs (unix-filename contexts)  
   "Return a summary of the references from a particular file.  
 The result is a list of the form (FILENAME ((REFERRER SOURCE-PATH) ...))"  
   (list unix-filename  
         (loop for context in (sort-contexts-by-source-path contexts)  
               collect (list (let ((*print-pretty* nil))  
                               (to-string (xref:xref-context-name context)))  
                             (xref:xref-context-source-path context)))))  
   
 (defun sort-contexts-by-source-path (contexts)  
   "Sort xref contexts by lexical position of source-paths.  
 It is assumed that all contexts belong to the same file."  
   (sort contexts #'source-path< :key #'xref:xref-context-source-path))  
   
 (defun source-path< (path1 path2)  
   "Return true if PATH1 is lexically before PATH2."  
   (and (every #'< path1 path2)  
        (< (length path1) (length path2))))  
   
396  (defun clear-xref-info (namestring)  (defun clear-xref-info (namestring)
397    "Clear XREF notes pertaining to FILENAME.    "Clear XREF notes pertaining to FILENAME.
398  This is a workaround for a CMUCL bug: XREF records are cumulative."  This is a workaround for a CMUCL bug: XREF records are cumulative."
# Line 551  the code omponent CODE." Line 541  the code omponent CODE."
541                                   (function-source-location fn)))                                   (function-source-location fn)))
542                           fns))))                           fns))))
543    
544    
545  ;;;; Definitions  ;;;; Definitions
546    
547  (defvar *debug-definition-finding* t  (defvar *debug-definition-finding* nil
548    "When true don't handle errors while looking for definitions.    "When true don't handle errors while looking for definitions.
549  This is useful when debugging the definition-finding code.")  This is useful when debugging the definition-finding code.")
550    
551  (defmacro safe-definition-finding (&body body)  (defmacro safe-definition-finding (&body body)
552    "Execute BODY ignoring errors.  Return a the source location    "Execute BODY ignoring errors.  Return the source location returned
553  returned by BODY or if an error occurs a description of the error.  by BODY or if an error occurs a description of the error.  The second
554  The second return value is the condition or nil."  return value is the condition or nil."
555    `(flet ((body () ,@body))    `(flet ((body () ,@body))
556      (if *debug-definition-finding*      (if *debug-definition-finding*
557          (body)          (body)
# Line 670  The second return value is the condition Line 661  The second return value is the condition
661    (destructuring-bind (first) (function-source-locations function)    (destructuring-bind (first) (function-source-locations function)
662      first))      first))
663    
664  (defslimefun find-function-locations (symbol-name)  (defmethod find-function-locations (symbol-name)
665    "Return a list of source-locations for SYMBOL-NAME's functions."    "Return a list of source-locations for SYMBOL-NAME's functions."
666    (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name)    (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name)
667      (cond ((not foundp)      (cond ((not foundp)
# Line 807  The result has the format \"(...)\"." Line 798  The result has the format \"(...)\"."
798  (defmethod macroexpand-all (form)  (defmethod macroexpand-all (form)
799    (walker:macroexpand-all form))    (walker:macroexpand-all form))
800    
801  (defun tracedp (fname)  (in-package :c)
802    (gethash (debug::trace-fdefinition fname)  
803             debug::*traced-functions*))  (defun swank::expand-ir1-top-level (form)
804      "A scaled down version of the first pass of the compiler."
805  (defslimefun toggle-trace-fdefinition (fname-string)    (with-compilation-unit ()
806    (let ((fname (from-string fname-string)))      (let* ((*lexical-environment*
807      (cond ((tracedp fname)              (make-lexenv :default (make-null-environment)
808             (debug::untrace-1 fname)                           :cookie *default-cookie*
809             (format nil "~S is now untraced." fname))                           :interface-cookie *default-interface-cookie*))
810            (t             (*source-info* (make-lisp-source-info form))
811             (debug::trace-1 fname (debug::make-trace-info))             (*block-compile* nil)
812             (format nil "~S is now traced." fname)))))             (*block-compile-default* nil))
813          (with-ir1-namespace
814              (clear-stuff)
815            (find-source-paths form 0)
816            (ir1-top-level form '(0) t)))))
817    
818    (in-package :swank)
819    
820    (defslimefun print-ir1-converted-blocks (form)
821      (with-output-to-string (*standard-output*)
822        (c::print-all-blocks (expand-ir1-top-level (from-string form)))))
823    
824  (defslimefun set-default-directory (directory)  (defslimefun set-default-directory (directory)
825    (setf (ext:default-directory) (namestring directory))    (setf (ext:default-directory) (namestring directory))
# Line 827  The result has the format \"(...)\"." Line 828  The result has the format \"(...)\"."
828    (setf *default-pathname-defaults* (pathname (ext:default-directory)))    (setf *default-pathname-defaults* (pathname (ext:default-directory)))
829    (namestring (ext:default-directory)))    (namestring (ext:default-directory)))
830    
831    ;;; source-path-{stream,file,string,etc}-position moved into
832  ;;;; Source-paths  ;;; swank-source-path-parser
   
 ;;; CMUCL uses a data structure called "source-path" to locate  
 ;;; subforms.  The compiler assigns a source-path to each form in a  
 ;;; compilation unit.  Compiler notes usually contain the source-path  
 ;;; of the error location.  
 ;;;  
 ;;; Compiled code objects don't contain source paths, only the  
 ;;; "toplevel-form-number" and the (sub-) "form-number".  To get from  
 ;;; the form-number to the source-path we need the entire toplevel-form  
 ;;; (i.e. we have to read the source code).  CMUCL has already some  
 ;;; utilities to do this translation, but we use some extended  
 ;;; versions, because we need more exact position info.  Apparently  
 ;;; Hemlock is happy with the position of the toplevel-form; we also  
 ;;; need the position of subforms.  
 ;;;  
 ;;; We use a special readtable to get the positions of the subforms.  
 ;;; The readtable stores the start and end position for each subform in  
 ;;; hashtable for later retrieval.  
   
 (defun make-source-recorder (fn source-map)  
   "Return a macro character function that does the same as FN, but  
 additionally stores the result together with the stream positions  
 before and after of calling FN in the hashtable SOURCE-MAP."  
   (lambda (stream char)  
     (let ((start (file-position stream))  
           (values (multiple-value-list (funcall fn stream char)))  
           (end (file-position stream)))  
       #+(or) (format t "~&[~D ~{~A~^, ~} ~D]~%" start values end)  
       (unless (null values)  
         (push (cons start end) (gethash (car values) source-map)))  
       (values-list values))))  
   
 (defun make-source-recording-readtable (readtable source-map)  
   "Return a source position recording copy of READTABLE.  
 The source locations are stored in SOURCE-MAP."  
   (let* ((tab (copy-readtable readtable))  
          (*readtable* tab))  
     (dotimes (code char-code-limit)  
       (let ((char (code-char code)))  
         (multiple-value-bind (fn term) (get-macro-character char tab)  
           (when fn  
             (set-macro-character char (make-source-recorder fn source-map)  
                                  term tab)))))  
     tab))  
   
 (defun make-source-map ()  
   (make-hash-table :test #'eq))  
   
 (defvar *source-map* (make-source-map)  
   "The hashtable table used for source position recording.")  
   
 (defvar *recording-readtable-cache* '()  
   "An alist of (READTABLE . RECORDING-READTABLE) pairs.")  
   
 (defun lookup-recording-readtable (readtable)  
   "Find a cached or create a new recording readtable for READTABLE."  
   (or (cdr (assoc readtable *recording-readtable-cache*))  
       (let ((table (make-source-recording-readtable readtable *source-map*)))  
         (push (cons readtable table) *recording-readtable-cache*)  
         table)))  
   
 (defun read-and-record-source-map (stream)  
   "Read the next object from STREAM.  
 Return the object together with a hashtable that maps  
 subexpressions of the object to stream positions."  
   (let ((*readtable* (lookup-recording-readtable *readtable*)))  
     (clrhash *source-map*)  
     (values (read stream) *source-map*)))  
   
 (defun source-path-stream-position (path stream)  
   "Search the source-path PATH in STREAM and return its position."  
   (destructuring-bind (tlf-number . path) path  
     (let ((*read-suppress* t))  
       (dotimes (i tlf-number) (read stream))  
       (multiple-value-bind (form source-map)  
           (read-and-record-source-map stream)  
         (source-path-source-position (cons 0 path) form source-map)))))  
   
 (defun source-path-string-position (path string)  
   (with-input-from-string (s string)  
     (source-path-stream-position path s)))  
   
 (defun source-path-file-position (path filename)  
   (with-open-file (file filename)  
     (source-path-stream-position path file)))  
   
 (defun source-path-source-position (path form source-map)  
   "Return the start position of PATH form FORM and SOURCE-MAP.  All  
 subforms along the path are considered and the start and end position  
 of deepest (i.e. smallest) possible form is returned."  
   ;; compute all subforms along path  
   (let ((forms (loop for n in path  
                      for f = form then (nth n f)  
                      collect f)))  
     ;; select the first subform present in source-map  
     (loop for form in (reverse forms)  
           for positions = (gethash form source-map)  
           until (and positions (null (cdr positions)))  
           finally (destructuring-bind ((start . end)) positions  
                     (return (values (1- start) end))))))  
833    
834  (defun code-location-stream-position (code-location stream)  (defun code-location-stream-position (code-location stream)
835    "Return the byte offset of CODE-LOCATION in STREAM.  Extract the    "Return the byte offset of CODE-LOCATION in STREAM.  Extract the
# Line 1028  format suitable for Emacs." Line 929  format suitable for Emacs."
929          collect (list (princ-to-string (restart-name restart))          collect (list (princ-to-string (restart-name restart))
930                        (princ-to-string restart))))                        (princ-to-string restart))))
931    
 (defun format-condition-for-emacs ()  
   (format nil "~A~%   [Condition of type ~S]"  
           (debug::safe-condition-message *swank-debugger-condition*)  
           (type-of *swank-debugger-condition*)))  
   
932  (defun nth-frame (index)  (defun nth-frame (index)
933    (do ((frame *sldb-stack-top* (di:frame-down frame))    (do ((frame *sldb-stack-top* (di:frame-down frame))
934         (i index (1- i)))         (i index (1- i)))
# Line 1041  format suitable for Emacs." Line 937  format suitable for Emacs."
937  (defun nth-restart (index)  (defun nth-restart (index)
938    (nth index *sldb-restarts*))    (nth index *sldb-restarts*))
939    
940  (defun format-frame-for-emacs (frame)  (defun format-frame-for-emacs (number frame)
941    (list (di:frame-number frame)    (print-with-frame-label
942          (with-output-to-string (*standard-output*)     number (lambda (*standard-output*)
943            (let ((*print-pretty* *sldb-pprint-frames*))              (debug::print-frame-call frame :verbosity 1 :number nil))))
             (debug::print-frame-call frame :verbosity 1 :number t)))))  
944    
945  (defun compute-backtrace (start end)  (defun compute-backtrace (start end)
946    "Return a list of frames starting with frame number START and    "Return a list of frames starting with frame number START and
# Line 1055  stack." Line 950  stack."
950      (loop for f = (nth-frame start) then (di:frame-down f)      (loop for f = (nth-frame start) then (di:frame-down f)
951            for i from start below end            for i from start below end
952            while f            while f
953            collect f)))            collect (cons i f))))
954    
955  (defmethod backtrace (start end)  (defmethod backtrace (start end)
956    (mapcar #'format-frame-for-emacs (compute-backtrace start end)))    (loop for (n . frame) in (compute-backtrace start end)
957            collect (list n (format-frame-for-emacs n frame))))
958    
959  (defmethod debugger-info-for-emacs (start end)  (defmethod debugger-info-for-emacs (start end)
960    (list (format-condition-for-emacs)    (list (debugger-condition-for-emacs)
961          (format-restarts-for-emacs)          (format-restarts-for-emacs)
962          (backtrace start end)))          (backtrace start end)))
963    
# Line 1085  stack." Line 981  stack."
981           (location (di:frame-code-location frame))           (location (di:frame-code-location frame))
982           (debug-function (di:frame-debug-function frame))           (debug-function (di:frame-debug-function frame))
983           (debug-variables (di::debug-function-debug-variables debug-function)))           (debug-variables (di::debug-function-debug-variables debug-function)))
984      (loop for v across debug-variables      (loop for v across debug-variables collect
985            collect (list            (list :name (to-string (di:debug-variable-symbol v))
986                     :symbol (di:debug-variable-symbol v)                  :id (di:debug-variable-id v)
987                     :id (di:debug-variable-id v)                  :value-string (ecase (di:debug-variable-validity v location)
988                     :value-string                                  (:valid
989                     (if (eq (di:debug-variable-validity v location)                                   (to-string (di:debug-variable-value v frame)))
990                             :valid)                                  ((:invalid :unknown)
991                         (to-string (di:debug-variable-value v frame))                                   "<not-available>"))))))
                        "<not-available>")))))  
992    
993  (defmethod frame-catch-tags (index)  (defmethod frame-catch-tags (index)
994    (loop for (tag . code-location) in (di:frame-catches (nth-frame index))    (loop for (tag . code-location) in (di:frame-catches (nth-frame index))
# Line 1105  stack." Line 1000  stack."
1000  (defslimefun sldb-abort ()  (defslimefun sldb-abort ()
1001    (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))    (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
1002    
1003    (defun set-step-breakpoints (frame)
1004      (when (di:debug-block-elsewhere-p (di:code-location-debug-block
1005                                         (di:frame-code-location frame)))
1006        (error "Cannot step, in elsewhere code~%"))
1007      (let* ((code-location (di:frame-code-location frame))
1008             (debug::*bad-code-location-types*
1009              (remove :call-site debug::*bad-code-location-types*))
1010             (next (debug::next-code-locations code-location)))
1011        (cond (next
1012               (let ((steppoints '()))
1013                 (flet ((hook (frame breakpoint)
1014                          (let ((debug:*stack-top-hint* frame))
1015                            (mapc #'di:delete-breakpoint steppoints)
1016                            (let ((cl (di::breakpoint-what breakpoint)))
1017                              (break "Breakpoint: ~S ~S"
1018                                     (di:code-location-kind cl)
1019                                     (di::compiled-code-location-pc cl))))))
1020                   (dolist (code-location next)
1021                     (let ((bp (di:make-breakpoint #'hook code-location
1022                                                   :kind :code-location)))
1023                       (di:activate-breakpoint bp)
1024                       (push bp steppoints))))))
1025             (t
1026              (flet ((hook (frame breakpoint values cookie)
1027                       (declare (ignore cookie))
1028                       (di:delete-breakpoint breakpoint)
1029                       (let ((debug:*stack-top-hint* frame))
1030                         (break "Function-end: ~A ~A" breakpoint values))))
1031                (let* ((debug-function (di:frame-debug-function frame))
1032                       (bp (di:make-breakpoint #'hook debug-function
1033                                               :kind :function-end)))
1034                  (di:activate-breakpoint bp)))))))
1035    
1036    (defslimefun sldb-step (frame)
1037      (cond ((find-restart 'continue *swank-debugger-condition*)
1038             (set-step-breakpoints (nth-frame frame))
1039             (continue *swank-debugger-condition*))
1040            (t
1041             (error "Cannot continue in from condition: ~A"
1042                    *swank-debugger-condition*))))
1043    
1044    (defslimefun sldb-disassemble (frame-number)
1045      "Return a string with the disassembly of frames code."
1046      ;; this could need some refactoring.
1047      (let* ((frame (nth-frame frame-number))
1048             (real-frame (di::frame-real-frame frame))
1049             (frame-pointer (di::frame-pointer real-frame))
1050             (debug-fun (di:frame-debug-function real-frame)))
1051        (with-output-to-string (*standard-output*)
1052          (format t "Frame: ~S~%~:[Real Frame: ~S~%~;~]Frame Pointer: ~S~%"
1053                  frame (eq frame real-frame) real-frame frame-pointer)
1054          (etypecase debug-fun
1055            (di::compiled-debug-function
1056             (let* ((code-loc (di:frame-code-location frame))
1057                    (component (di::compiled-debug-function-component debug-fun))
1058                    (pc (di::compiled-code-location-pc code-loc))
1059                    (ip (sys:sap-int
1060                         (sys:sap+ (kernel:code-instructions component) pc)))
1061                    (kind (if (di:code-location-unknown-p code-loc)
1062                              :unkown
1063                              (di:code-location-kind code-loc)))
1064                    (fun (di:debug-function-function debug-fun)))
1065               (format t "Instruction pointer: #x~X [pc: ~S kind: ~S]~%~%~%"
1066                       ip pc kind)
1067               (if fun
1068                   (disassemble fun)
1069                   (disassem:disassemble-code-component component))))
1070            (di::bogus-debug-function
1071             (format t "~%[Disassembling bogus frames not implemented]"))))))
1072    
1073  ;;;; Inspecting  ;;;; Inspecting
1074    
 (defvar *inspectee*)  
 (defvar *inspectee-parts*)  
 (defvar *inspector-stack* '())  
 (defvar *inspector-history* (make-array 10 :adjustable t :fill-pointer 0))  
 (defvar *inspect-length* 30)  
   
 (defun reset-inspector ()  
   (setq *inspectee* nil)  
   (setq *inspectee-parts* nil)  
   (setq *inspector-stack* nil)  
   (setf (fill-pointer *inspector-history*) 0))  
   
 (defslimefun init-inspector (string)  
   (reset-inspector)  
   (inspect-object (eval (from-string string))))  
   
 (defun print-part-to-string (value)  
   (let ((*print-pretty* nil))  
     (let ((string (to-string value))  
           (pos (position value *inspector-history*)))  
       (if pos  
           (format nil "#~D=~A" pos string)  
           string))))  
   
 (defun inspect-object (object)  
   (push (setq *inspectee* object) *inspector-stack*)  
   (unless (find object *inspector-history*)  
     (vector-push-extend object *inspector-history*))  
   (multiple-value-bind (text parts) (inspected-parts object)  
     (setq *inspectee-parts* parts)  
       (list :text text  
             :type (to-string (type-of object))  
             :primitive-type (describe-primitive-type object)  
             :parts (loop for (label . value) in parts  
                          collect (cons label  
                                        (print-part-to-string value))))))  
1075  (defconstant +lowtag-symbols+  (defconstant +lowtag-symbols+
1076    '(vm:even-fixnum-type    '(vm:even-fixnum-type
1077      vm:function-pointer-type      vm:function-pointer-type
# Line 1168  stack." Line 1096  stack."
1096       (append (apropos-list "-TYPE" "VM" t)       (append (apropos-list "-TYPE" "VM" t)
1097               (apropos-list "-TYPE" "BIGNUM" t)))))               (apropos-list "-TYPE" "BIGNUM" t)))))
1098    
1099  (defun describe-primitive-type (object)  (defmethod describe-primitive-type (object)
1100    (with-output-to-string (*standard-output*)    (with-output-to-string (*standard-output*)
1101      (let* ((lowtag (kernel:get-lowtag object))      (let* ((lowtag (kernel:get-lowtag object))
1102             (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value)))             (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value)))
# Line 1184  stack." Line 1112  stack."
1112                 (format t ", type: ~A]" type-symbol)))                 (format t ", type: ~A]" type-symbol)))
1113              (t (format t "]"))))))              (t (format t "]"))))))
1114    
 (defun nth-part (index)  
   (cdr (nth index *inspectee-parts*)))  
   
 (defslimefun inspect-nth-part (index)  
   (inspect-object (nth-part index)))  
   
 (defslimefun inspector-pop ()  
   "Drop the inspector stack and inspect the second element.  Return  
 nil if there's no second element."  
   (cond ((cdr *inspector-stack*)  
          (pop *inspector-stack*)  
          (inspect-object (pop *inspector-stack*)))  
         (t nil)))  
   
 (defslimefun inspector-next ()  
   "Inspect the next element in the *inspector-history*."  
   (let ((position (position *inspectee* *inspector-history*)))  
     (cond ((= (1+ position) (length *inspector-history*))  
            nil)  
           (t (inspect-object (aref *inspector-history* (1+ position)))))))  
   
 (defslimefun quit-inspector ()  
   (reset-inspector)  
   nil)  
   
 (defslimefun describe-inspectee ()  
   "Describe the currently inspected object."  
   (print-description-to-string *inspectee*))  
   
 (defgeneric inspected-parts (object)  
   (:documentation  
    "Return a short description and a list of (label . value) pairs."))  
   
1115  (defmethod inspected-parts (o)  (defmethod inspected-parts (o)
1116    (cond ((di::indirect-value-cell-p o)    (cond ((di::indirect-value-cell-p o)
1117           (inspected-parts-of-value-cell o))           (inspected-parts-of-value-cell o))
# Line 1231  nil if there's no second element." Line 1126  nil if there's no second element."
1126                                    collect (cons (format nil "~D" i) value)))))                                    collect (cons (format nil "~D" i) value)))))
1127               (values text parts))))))               (values text parts))))))
1128    
 (defun inspected-parts-of-value-cell (o)  
   (values (format nil "~A~% is a value cell." o)  
           (list (cons "Value" (c:value-cell-ref o)))))  
   
 ;; borrowed from sbcl  
 (defmethod inspected-parts ((object cons))  
   (if (consp (cdr object))  
       (inspected-parts-of-nontrivial-list object)  
       (inspected-parts-of-simple-cons object)))  
   
 (defun inspected-parts-of-simple-cons (object)  
   (values "The object is a CONS."  
           (list (cons (string 'car) (car object))  
                 (cons (string 'cdr) (cdr object)))))  
   
 (defun inspected-parts-of-nontrivial-list (object)  
   (let ((length 0)  
         (in-list object)  
         (reversed-elements nil))  
     (flet ((done (description-format)  
              (return-from inspected-parts-of-nontrivial-list  
                (values (format nil description-format length)  
                        (nreverse reversed-elements)))))  
       (loop  
        (cond ((null in-list)  
               (done "The object is a proper list of length ~S.~%"))  
              ((>= length *inspect-length*)  
               (push (cons  (string 'rest) in-list) reversed-elements)  
               (done "The object is a long list (more than ~S elements).~%"))  
              ((consp in-list)  
               (push (cons (format nil "~D" length) (pop in-list))  
                     reversed-elements)  
               (incf length))  
              (t  
               (push (cons (string 'rest) in-list) reversed-elements)  
               (done "The object is an improper list of length ~S.~%")))))))  
   
1129  (defmethod inspected-parts ((o function))  (defmethod inspected-parts ((o function))
1130    (let ((header (kernel:get-type o)))    (let ((header (kernel:get-type o)))
1131      (cond ((= header vm:function-header-type)      (cond ((= header vm:function-header-type)
# Line 1304  nil if there's no second element." Line 1162  nil if there's no second element."
1162            `(("Name" . ,(kernel:fdefn-name o))            `(("Name" . ,(kernel:fdefn-name o))
1163              ("Function" . ,(kernel:fdefn-function o)))))              ("Function" . ,(kernel:fdefn-function o)))))
1164    
1165    
1166    ;;;; Multiprocessing
1167    
1168    #+MP
1169    (progn
1170      (defvar *known-processes* '()         ; FIXME: leakage. -luke
1171        "List of processes that have been assigned IDs.
1172         The ID is the position in the list.")
1173    
1174      (defmethod startup-multiprocessing ()
1175        (setq *swank-in-background* :spawn)
1176        ;; Threads magic: this never returns! But top-level becomes
1177        ;; available again.
1178        (mp::startup-idle-and-top-level-loops))
1179    
1180      (defmethod thread-id ()
1181        (mp:without-scheduling
1182         (or (find-thread-id)
1183             (prog1 (length *known-processes*)
1184               (setq *known-processes*
1185                     (append *known-processes* (list (mp:current-process))))))))
1186    
1187      (defun find-thread-id (&optional (process (mp:current-process)))
1188        (position process *known-processes*))
1189    
1190      (defun lookup-thread (thread-id)
1191        (or (nth thread-id *known-processes*)
1192            (error "Unknown Thread-ID: ~S" thread-id)))
1193    
1194      (defmethod thread-name (thread-id)
1195        (mp:process-name (lookup-thread thread-id)))
1196    
1197      (defmethod make-lock (&key name)
1198        (mp:make-lock name))
1199    
1200      (defmethod call-with-lock-held (lock function)
1201        (mp:with-lock-held (lock)
1202          (funcall function)))
1203    )
1204    
1205    
1206    ;;;; Epilogue
1207  ;;; Local Variables:  ;;; Local Variables:
1208  ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)"  (1 font-lock-keyword-face) (2 font-lock-function-name-face))))  ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)"  (1 font-lock-keyword-face) (2 font-lock-function-name-face))))
1209  ;;; End:  ;;; End:

Legend:
Removed from v.1.32  
changed lines
  Added in v.1.51

  ViewVC Help
Powered by ViewVC 1.1.5