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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (hide annotations)
Sat Sep 13 23:05:58 2003 UTC (10 years, 7 months ago) by lukeg
Branch: MAIN
Changes since 1.5: +200 -88 lines
Debugger from Helmut, new communication protocol.
1 lukeg 1.1 (defpackage :swank
2 lukeg 1.6 (:use :common-lisp)
3 lukeg 1.4 (:export #:start-server #:evaluate #:lookup-notes #:clear-notes
4     #:swank-compile-file #:swank-compile-string
5     #:arglist-string #:completions
6 lukeg 1.6 #:find-fdefinition
7     #:eval-string-async
8     #:sldb-loop))
9 lukeg 1.1
10     (in-package :swank)
11    
12 lukeg 1.6 (defconstant server-port 4005
13 lukeg 1.1 "Default port for the swank TCP server.")
14    
15     (defvar *notes-database* (make-hash-table :test #'equal)
16     "Database of recorded compiler notes/warnings/erros (keyed by filename).
17     Each value is a list of (LOCATION SEVERITY MESSAGE CONTEXT) lists.
18     LOCATION is a position in the source code (integer or source path).
19     SEVERITY is one of :ERROR, :WARNING, and :NOTE.
20     MESSAGE is a string describing the note.
21     CONTEXT is a string giving further details of where the error occured.")
22    
23     (defvar *swank-debug-p* nil
24     "When true extra debug printouts are enabled.")
25    
26     ;;; Setup and hooks.
27    
28     (defun start-server (&optional (port server-port))
29 lukeg 1.6 (create-swank-server port :reuse-address t)
30 lukeg 1.1 (setf c:*record-xref-info* t)
31     (ext:without-package-locks
32     (setf c:*compiler-notification-function* #'handle-notification))
33     (when *swank-debug-p*
34     (format *debug-io* "~&Swank ready.~%")))
35    
36     (defun debugger-hook (condition old-hook)
37     "Hook function to be invoked instead of the debugger.
38     See CL:*DEBUGGER-HOOK*."
39     ;; FIXME: Debug from Emacs!
40     (declare (ignore old-hook))
41     (handler-case
42     (progn (format *error-output*
43     "~@<SWANK: unhandled condition ~2I~_~A~:>~%"
44     condition)
45     (debug:backtrace 20 *error-output*)
46     (finish-output *error-output*))
47     (condition ()
48     nil)))
49    
50     (defun handle-notification (severity message context where-from position)
51     "Hook function called by the compiler.
52     See C:*COMPILER-NOTIFICATION-FUNCTION*"
53     (let ((location (or (current-compiler-error-source-path) position))
54     (namestring (cond ((stringp where-from) where-from)
55     ;; we can be passed a stream from READER-ERROR
56     ((lisp::fd-stream-p where-from)
57     (lisp::fd-stream-file where-from))
58     (t where-from))))
59     (when namestring
60     (push (list location severity message context)
61     (gethash namestring *notes-database*)))))
62    
63     (defun current-compiler-error-source-path ()
64     "Return the source-path for the current compiler error.
65     Returns NIL if this cannot be determined by examining internal
66     compiler state."
67     (let ((context c::*compiler-error-context*))
68     (cond ((c::node-p context)
69     (reverse
70     (c::source-path-original-source (c::node-source-path context))))
71     ((c::compiler-error-context-p context)
72     (reverse
73     (c::compiler-error-context-original-source-path context))))))
74    
75 lukeg 1.6 ;;; TCP Server.
76 lukeg 1.1
77 lukeg 1.6 (defvar *emacs-io* nil
78     "Bound to a TCP stream to Emacs during request processing.")
79 lukeg 1.1
80 lukeg 1.6 (defun create-swank-server (port &key reuse-address)
81     "Create a SWANK TCP server."
82     (system:add-fd-handler
83     (ext:create-inet-listener port :stream :reuse-address reuse-address)
84     :input #'accept-connection))
85    
86     (defun accept-connection (socket)
87     "Accept a SWANK TCP connection on SOCKET."
88     (setup-request-handler (ext:accept-tcp-connection socket)))
89    
90     (defun setup-request-handler (socket)
91     "Setup request handling for SOCKET."
92     (let ((stream (sys:make-fd-stream socket
93     :input t :output t
94     :element-type 'unsigned-byte)))
95     (system:add-fd-handler socket
96     :input (lambda (fd)
97     (declare (ignore fd))
98     (serve-request stream)))))
99    
100     (defun serve-request (*emacs-io*)
101     "Read and process a request from a SWANK client.
102     The request is read from the socket as a sexp and then evaluated."
103 lukeg 1.1 (handler-case
104 lukeg 1.6 (let* ((length (logior (ash (read-byte *emacs-io*) 16)
105     (ash (read-byte *emacs-io*) 8)
106     (read-byte *emacs-io*)))
107     (string (make-string length)))
108     (sys:read-n-bytes *emacs-io* string 0 length)
109     (eval (read-from-string string)))
110     (stream-error (condition)
111     (when *swank-debug-p*
112     (format *debug-io* "~&;; Connection to Emacs lost.~%"))
113     (sys:invalidate-descriptor (sys:fd-stream-fd *emacs-io*)))))
114    
115     (defun send-to-emacs (object)
116     "Send OBJECT to Emacs."
117     (let* ((string (prin1-to-string-for-emacs object))
118     (length (length string)))
119     (loop for position from 16 downto 0 by 8
120     do (write-byte (ldb (byte 8 position) length) *emacs-io*))
121     (write-string string *emacs-io*)
122     (force-output *emacs-io*)))
123    
124     (defun read-from-emacs ()
125     "Read and process a request from Emacs."
126     (serve-request *emacs-io*))
127    
128     (defun prin1-to-string-for-emacs (object)
129     (let ((*print-case* :downcase))
130     (format nil "~S~%" object)))
131    
132     ;;; Functions for Emacs to call.
133 lukeg 1.1
134 lukeg 1.4 (defun swank-compile-string (string buffer start)
135     (with-input-from-string (stream string)
136     (multiple-value-list
137     (ext:compile-from-stream stream :source-info (cons buffer start)))))
138    
139 lukeg 1.1 ;;;; LOOKUP-NOTES -- interface
140    
141 lukeg 1.4 (defun canonicalize-filename (filename)
142     (namestring (unix:unix-resolve-links filename)))
143    
144 lukeg 1.1 (defun lookup-notes (filename)
145     "Return the compiler notes recorded for FILENAME.
146     \(See *NOTES-DATABASE* for a description of the return type.)"
147 lukeg 1.4 (gethash (canonicalize-filename filename) *notes-database*))
148    
149     (defun clear-notes (filename)
150     (remhash (canonicalize-filename filename) *notes-database*))
151 lukeg 1.1
152     ;;;; ARGLIST-STRING -- interface
153     (defun arglist-string (function)
154     "Return a string describing the argument list for FUNCTION.
155     The result has the format \"(...)\"."
156     (declare (type (or symbol function) function))
157     (let ((arglist
158     (if (not (or (fboundp function)
159     (functionp function)))
160     "(-- <Unknown-Function>)"
161     (let* ((fun (etypecase function
162     (symbol (or (macro-function function)
163     (symbol-function function)))
164     (function function)))
165     (df (di::function-debug-function fun))
166     (arglist (kernel:%function-arglist fun)))
167     (cond ((eval:interpreted-function-p fun)
168     (eval:interpreted-function-arglist fun))
169     ((pcl::generic-function-p fun)
170     (pcl::gf-pretty-arglist fun))
171     (arglist arglist)
172     ;; this should work both for
173     ;; compiled-debug-function and for
174     ;; interpreted-debug-function
175     (df (di::debug-function-lambda-list df))
176     (t "(<arglist-unavailable>)"))))))
177     (if (stringp arglist)
178     arglist
179 lukeg 1.6 (prin1-to-string-for-emacs arglist))))
180 lukeg 1.1
181     ;;;; COMPLETIONS -- interface
182    
183 lukeg 1.2 (defun completions (prefix package-name &optional only-external-p)
184 lukeg 1.1 "Return a list of completions for a symbol's PREFIX and PACKAGE-NAME.
185     The result is a list of symbol-name strings. All symbols accessible in
186     the package are considered."
187 lukeg 1.2 (let ((completions nil)
188     (package (find-package package-name)))
189     (when package
190     (do-symbols (symbol package)
191     (when (and (or (not only-external-p) (symbol-external-p symbol))
192     (string-prefix-p prefix (symbol-name symbol)))
193     (push (symbol-name symbol) completions))))
194 lukeg 1.1 completions))
195 lukeg 1.2
196 lukeg 1.5 (defun symbol-external-p (s)
197     (multiple-value-bind (_ status)
198     (find-symbol (symbol-name s) (symbol-package s))
199     (declare (ignore _))
200     (eq status :external)))
201    
202 lukeg 1.1 (defun string-prefix-p (s1 s2)
203     "Return true iff the string S1 is a prefix of S2.
204     \(This includes the case where S1 is equal to S2.)"
205     (and (<= (length s1) (length s2))
206     (string= s1 s2 :end2 (length s1))))
207 lukeg 1.3
208     ;;;; Definitions
209    
210     ;;; FIND-FDEFINITION -- interface
211     ;;;
212     (defun find-fdefinition (symbol-name package-name)
213     "Return the name of the file in which the function was defined, or NIL."
214     (fdefinition-file (read-symbol/package symbol-name package-name)))
215    
216     ;;; Clone of HEMLOCK-INTERNALS::FUN-DEFINED-FROM-PATHNAME
217     (defun fdefinition-file (function)
218     "Return the name of the file in which FUNCTION was defined."
219     (declare (type (or symbol function) function))
220     (typecase function
221     (symbol
222     (let ((def (or (macro-function function)
223     (and (fboundp function)
224     (fdefinition function)))))
225     (when def (fdefinition-file def))))
226     (kernel:byte-closure
227     (fdefinition-file (kernel:byte-closure-function function)))
228     (kernel:byte-function
229     (code-definition-file (c::byte-function-component function)))
230     (function
231     (code-definition-file (kernel:function-code-header
232     (kernel:%function-self function))))
233     (t nil)))
234    
235     (defun code-definition-file (code)
236     "Return the name of the file in which CODE was defined."
237     (declare (type kernel:code-component code))
238     (flet ((to-namestring (pathname)
239     (handler-case (namestring (truename pathname))
240     (file-error () nil))))
241     (let ((info (kernel:%code-debug-info code)))
242     (when info
243     (let ((source (car (c::debug-info-source info))))
244     (when (and source (eq (c::debug-source-from source) :file))
245     (to-namestring (c::debug-source-name source))))))))
246    
247     ;;;; Utilities.
248    
249     (defun read-symbol/package (symbol-name package-name)
250     (let ((package (find-package package-name)))
251     (unless package (error "No such package: %S" package-name))
252     (handler-case
253     (let ((*package* package))
254     (read-from-string symbol-name))
255     (reader-error () nil))))
256 lukeg 1.4
257     ;;; Asynchronous eval
258    
259     (defun guess-package-from-string (name)
260     (or (and name
261     (or (find-package name)
262     (find-package (string-upcase name))))
263     *package*))
264    
265     (defun read-catch-errors (string)
266     (let (form (error nil))
267     (handler-case
268     (setq form (read-from-string string))
269     (t (condition) (setq error (princ-to-string condition))))
270     (values form error)))
271    
272     (defvar *swank-debugger-condition*)
273     (defvar *swank-debugger-hook*)
274    
275     (defun eval-string-async (string package-name id)
276     (let ((*package* (guess-package-from-string package-name)))
277     (multiple-value-bind (form error) (read-catch-errors string)
278     (if error
279     (send-to-emacs `(:CALL-CONTINUATION ,id (:READ-FAILED ,error)))
280     (let ((*debugger-hook*
281     (lambda (condition hook)
282 lukeg 1.6 (send-to-emacs `(:DEBUGGER-HOOK
283 lukeg 1.4 ,debug::*debug-command-level*))
284     (let ((*swank-debugger-condition* condition)
285     (*swank-debugger-hook* hook))
286 lukeg 1.6 (read-from-emacs)))))
287 lukeg 1.4 (let (ok result)
288     (unwind-protect
289     (progn (setq result (eval form))
290     (setq ok t))
291 lukeg 1.6 (send-to-emacs `(:CALL-CONTINUATION ,id
292     ,(if ok
293     `(:OK ,result)
294     `(:ABORTED)))))))))))
295 lukeg 1.4
296     (defun briefely-describe-symbol-for-emacs (symbol)
297     "Return a plist of describing SYMBOL. Return NIL if the symbol is
298     unbound."
299     (let ((result '()))
300     (labels ((first-line (string)
301     (subseq string 0 (position #\newline string)))
302     (doc (kind)
303     (let ((string (documentation symbol kind)))
304     (if string
305     (first-line string)
306     :not-documented)))
307     (maybe-push (property value)
308     (when value
309     (setf result (list* property value result)))))
310     (maybe-push
311     :variable (multiple-value-bind (kind recorded-p)
312     (ext:info variable kind symbol)
313     (declare (ignore kind))
314     (if (or (boundp symbol) recorded-p)
315     (doc 'variable))))
316     (maybe-push
317     :function (if (fboundp symbol)
318     (doc 'function)))
319     (maybe-push
320     :setf (if (or (ext:info setf inverse symbol)
321     (ext:info setf expander symbol))
322     (doc 'setf)))
323     (maybe-push
324     :type (if (ext:info type kind symbol)
325     (doc 'type)))
326     (maybe-push
327     :class (if (find-class symbol nil)
328     (doc 'class)))
329     (if result
330 lukeg 1.6 (list* :designator (prin1-to-string-for-emacs symbol) result)))))
331 lukeg 1.4
332     (defun apropos-list-for-emacs (name)
333     (list (package-name *package*)
334     (ext:collect ((pack))
335     (ext:map-apropos
336     (lambda (symbol)
337     (unless (keywordp symbol)
338     (let ((plist (briefely-describe-symbol-for-emacs symbol)))
339     (when plist
340     (pack plist)))))
341     name)
342     (pack))))
343    
344     (defun set-stdin-non-blocking ()
345     (let ((fd (sys:fd-stream-fd sys:*stdin*)))
346     (flet ((fcntl (fd cmd arg)
347     (multiple-value-bind (flags errno) (unix:unix-fcntl fd cmd arg)
348     (or flags
349     (error "fcntl: ~A" (unix:get-unix-error-msg errno))))))
350     (let ((flags (fcntl fd unix:F-GETFL 0)))
351     (fcntl fd unix:F-SETFL (logior flags unix:O_NONBLOCK))))))
352    
353     (set-stdin-non-blocking)
354 lukeg 1.1
355 lukeg 1.6
356     ;;; Debugging stuff
357    
358     (defvar *sldb-level* 0)
359     (defvar *sldb-stack-top*)
360     (defvar *sldb-restarts*)
361    
362     (defun sldb-loop ()
363     (unix:unix-sigsetmask 0)
364     (let* ((*sldb-level* (1+ *sldb-level*))
365     (*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame)))
366     (*sldb-restarts* (compute-restarts *swank-debugger-condition*))
367     (debug:*stack-top-hint* nil)
368     (*debugger-hook* nil)
369     (level *sldb-level*))
370     (unwind-protect
371     (loop
372     (with-simple-restart (abort "Return to sldb level ~D." level)
373     (send-to-emacs `(:sldb-prompt ,level))
374     (read-from-emacs)))
375     (send-to-emacs `(:sldb-abort ,level)))))
376    
377     (defun format-restarts-for-emacs ()
378     "Return a list of restarts for *swank-debugger-condition* in a
379     format suitable for Emacs."
380     (loop for restart in *sldb-restarts*
381     collect (list (princ-to-string (restart-name restart))
382     (princ-to-string restart))))
383    
384     (defun format-condition-for-emacs ()
385     (format nil "~A~% [Condition of type ~S]"
386     (debug::safe-condition-message *swank-debugger-condition*)
387     (type-of *swank-debugger-condition*)))
388    
389     (defun compute-backtrace ()
390     (loop for frame = *sldb-stack-top* then (di:frame-down frame)
391     while frame collect frame))
392    
393     (defun format-frame-for-emacs (frame)
394     (list (di:frame-number frame)
395     (with-output-to-string (*standard-output*)
396     (debug::print-frame-call frame :verbosity 1))))
397    
398     (defun backtrace-for-emacs (start end)
399     (let ((frames (compute-backtrace)))
400     (list (length frames)
401     (mapcar #'format-frame-for-emacs (subseq frames start end)))))
402    
403     (defun debugger-info-for-emacs (start end)
404     (list (format-condition-for-emacs)
405     (format-restarts-for-emacs)
406     (backtrace-for-emacs start end)))
407    
408     (defun nth-frame (index)
409     (nth index (compute-backtrace)))
410    
411     (defun nth-restart (index)
412     (nth index *sldb-restarts*))
413    
414     (defun code-location-source-path (code-location)
415     (let* ((location (debug::maybe-block-start-location code-location))
416     (form-num (di:code-location-form-number location)))
417     (let ((translations (debug::get-top-level-form location)))
418     (unless (< form-num (length translations))
419     (error "Source path no longer exists."))
420     (reverse (cdr (svref translations form-num))))))
421    
422     (defun code-location-file-position (code-location)
423     (let* ((debug-source (di:code-location-debug-source code-location))
424     (filename (di:debug-source-name debug-source))
425     (path (code-location-source-path code-location)))
426     (source-path-file-position path filename)))
427    
428     (defun source-path-file-position (path filename)
429     (let ((*read-suppress* t))
430     (with-open-file (file filename)
431     (dolist (n path)
432     (dotimes (i n)
433     (read file))
434     (read-delimited-list #\( file))
435     (let ((start (file-position file)))
436     (file-position file (1- start))
437     (read file)
438     (list start (file-position file))))))
439    
440     (defun frame-code-location-for-emacs (index)
441     (let* ((frame (nth-frame index))
442     (code-location (di:frame-code-location frame))
443     (debug-source (di:code-location-debug-source code-location))
444     (from (di:debug-source-from debug-source))
445     (name (di:debug-source-name debug-source)))
446     (list
447     :from from
448     :filename (if (eq from :file)
449     (ext:unix-namestring (truename name)))
450     :position (if (eq from :file)
451     (code-location-file-position code-location))
452     :source-form
453     (with-output-to-string (*standard-output*)
454     (debug::print-code-location-source-form code-location 100 t)))))
455    
456     (defun safe-frame-code-location-for-emacs (index)
457     (handler-case (frame-code-location-for-emacs index)
458     (t (c) (list :error (debug::safe-condition-message c)))))
459    
460     (defun eval-string-in-frame (string index)
461     (prin1-to-string-for-emacs
462     (di:eval-in-frame (nth-frame index) (read-from-string string))))
463    
464     (defun list-locals (index)
465     (let* ((frame (nth-frame index))
466     (location (di:frame-code-location frame))
467     (debug-function (di:frame-debug-function frame))
468     (debug-variables (di:ambiguous-debug-variables debug-function "")))
469     (with-output-to-string (*standard-output*)
470     (dolist (v debug-variables)
471     (format t "~S~:[#~D~;~*~] ~A~& ~S~&"
472     (di:debug-variable-symbol v)
473     (zerop (di:debug-variable-id v))
474     (di:debug-variable-id v)
475     (di:debug-variable-validity v location)
476     (di:debug-variable-value v frame))))))
477    
478     (defun invoke-nth-restart (index)
479     (invoke-restart (nth-restart index)))
480    
481     (defun quit-from-debugger ()
482     (throw 'lisp::top-level-catcher nil))
483    
484     ;; (+ 1 1)
485     ;; (/ 1 0)

  ViewVC Help
Powered by ViewVC 1.1.5