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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (show annotations)
Mon Sep 15 02:50:20 2003 UTC (10 years, 7 months ago) by lukeg
Branch: MAIN
Changes since 1.7: +44 -16 lines
(apropos-list-for-emacs): Hacked the apropos listing to accept more
options and to specially sort results.
1 (defpackage :swank
2 (:use :common-lisp)
3 (:export #:start-server #:evaluate #:lookup-notes #:clear-notes
4 #:swank-compile-file #:swank-compile-string
5 #:arglist-string #:completions
6 #:find-fdefinition
7 #:eval-string
8 #:sldb-loop))
9
10 (in-package :swank)
11
12 (defconstant server-port 4005
13 "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* t
24 "When true extra debug printouts are enabled.")
25
26 ;;; Setup and hooks.
27
28 (defun start-server (&optional (port server-port))
29 (create-swank-server port :reuse-address t)
30 (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 ;;; TCP Server.
76
77 (defvar *emacs-io* nil
78 "Bound to a TCP stream to Emacs during request processing.")
79
80 (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 (let ((completed nil))
104 (let ((condition (catch 'serve-request-catcher
105 (read-from-emacs)
106 (setq completed t))))
107 (unless completed
108 (when *swank-debug-p*
109 (format *debug-io*
110 "~&;; Connection to Emacs lost.~%;; [~A]~%" condition))
111 (sys:invalidate-descriptor (sys:fd-stream-fd *emacs-io*))
112 (close *emacs-io*)))))
113
114 (defun read-next-form ()
115 (handler-case
116 (let* ((length (logior (ash (read-byte *emacs-io*) 16)
117 (ash (read-byte *emacs-io*) 8)
118 (read-byte *emacs-io*)))
119 (string (make-string length)))
120 (sys:read-n-bytes *emacs-io* string 0 length)
121 (read-form string))
122 (condition (c)
123 (throw 'serve-request-catcher c))))
124
125 (defvar *swank-io-package*
126 (let ((package (make-package "SWANK-IO-PACKAGE")))
127 (import 'nil package)
128 package))
129
130 (defun read-form (string)
131 (let ((*package* *swank-io-package*))
132 (with-standard-io-syntax
133 (read-from-string string))))
134
135 (defun read-from-emacs ()
136 "Read and process a request from Emacs."
137 (eval (read-next-form)))
138
139 (defun send-to-emacs (object)
140 "Send OBJECT to Emacs."
141 (let* ((string (prin1-to-string-for-emacs object))
142 (length (length string)))
143 (loop for position from 16 downto 0 by 8
144 do (write-byte (ldb (byte 8 position) length) *emacs-io*))
145 (write-string string *emacs-io*)
146 (force-output *emacs-io*)))
147
148 (defun prin1-to-string-for-emacs (object)
149 (let ((*print-case* :downcase)
150 (*print-readably* t)
151 (*print-pretty* nil)
152 (*package* *swank-io-package*))
153 (prin1-to-string object)))
154
155 ;;; Functions for Emacs to call.
156
157 ;;;; LOOKUP-NOTES -- interface
158
159 (defun canonicalize-filename (filename)
160 (namestring (unix:unix-resolve-links filename)))
161
162 (defun lookup-notes (filename)
163 "Return the compiler notes recorded for FILENAME.
164 \(See *NOTES-DATABASE* for a description of the return type.)"
165 (gethash (canonicalize-filename filename) *notes-database*))
166
167 (defun clear-notes (filename)
168 (remhash (canonicalize-filename filename) *notes-database*))
169
170 ;;;; ARGLIST-STRING -- interface
171 (defun arglist-string (function)
172 "Return a string describing the argument list for FUNCTION.
173 The result has the format \"(...)\"."
174 (declare (type (or symbol function) function))
175 (let ((arglist
176 (if (not (or (fboundp function)
177 (functionp function)))
178 "(-- <Unknown-Function>)"
179 (let* ((fun (etypecase function
180 (symbol (or (macro-function function)
181 (symbol-function function)))
182 (function function)))
183 (df (di::function-debug-function fun))
184 (arglist (kernel:%function-arglist fun)))
185 (cond ((eval:interpreted-function-p fun)
186 (eval:interpreted-function-arglist fun))
187 ((pcl::generic-function-p fun)
188 (pcl::gf-pretty-arglist fun))
189 (arglist arglist)
190 ;; this should work both for
191 ;; compiled-debug-function and for
192 ;; interpreted-debug-function
193 (df (di::debug-function-lambda-list df))
194 (t "(<arglist-unavailable>)"))))))
195 (if (stringp arglist)
196 arglist
197 (prin1-to-string-for-emacs arglist))))
198
199 ;;;; COMPLETIONS -- interface
200
201 (defun completions (prefix package-name &optional only-external-p)
202 "Return a list of completions for a symbol's PREFIX and PACKAGE-NAME.
203 The result is a list of symbol-name strings. All symbols accessible in
204 the package are considered."
205 (let ((completions nil)
206 (package (find-package package-name)))
207 (when package
208 (do-symbols (symbol package)
209 (when (and (or (not only-external-p) (symbol-external-p symbol))
210 (string-prefix-p prefix (symbol-name symbol)))
211 (push (symbol-name symbol) completions))))
212 completions))
213
214 (defun symbol-external-p (s)
215 (multiple-value-bind (_ status)
216 (find-symbol (symbol-name s) (symbol-package s))
217 (declare (ignore _))
218 (eq status :external)))
219
220 (defun string-prefix-p (s1 s2)
221 "Return true iff the string S1 is a prefix of S2.
222 \(This includes the case where S1 is equal to S2.)"
223 (and (<= (length s1) (length s2))
224 (string= s1 s2 :end2 (length s1))))
225
226 ;;;; Definitions
227
228 ;;; FIND-FDEFINITION -- interface
229 ;;;
230 (defun find-fdefinition (symbol-name package-name)
231 "Return the name of the file in which the function was defined, or NIL."
232 (fdefinition-file (read-symbol/package symbol-name package-name)))
233
234 ;;; Clone of HEMLOCK-INTERNALS::FUN-DEFINED-FROM-PATHNAME
235 (defun fdefinition-file (function)
236 "Return the name of the file in which FUNCTION was defined."
237 (declare (type (or symbol function) function))
238 (typecase function
239 (symbol
240 (let ((def (or (macro-function function)
241 (and (fboundp function)
242 (fdefinition function)))))
243 (when def (fdefinition-file def))))
244 (kernel:byte-closure
245 (fdefinition-file (kernel:byte-closure-function function)))
246 (kernel:byte-function
247 (code-definition-file (c::byte-function-component function)))
248 (function
249 (code-definition-file (kernel:function-code-header
250 (kernel:%function-self function))))
251 (t nil)))
252
253 (defun code-definition-file (code)
254 "Return the name of the file in which CODE was defined."
255 (declare (type kernel:code-component code))
256 (flet ((to-namestring (pathname)
257 (handler-case (namestring (truename pathname))
258 (file-error () nil))))
259 (let ((info (kernel:%code-debug-info code)))
260 (when info
261 (let ((source (car (c::debug-info-source info))))
262 (when (and source (eq (c::debug-source-from source) :file))
263 (to-namestring (c::debug-source-name source))))))))
264
265 ;;;; Utilities.
266
267 (defun read-symbol/package (symbol-name package-name)
268 (let ((package (find-package package-name)))
269 (unless package (error "No such package: ~S" package-name))
270 (handler-case
271 (let ((*package* package))
272 (read-from-string symbol-name))
273 (reader-error () nil))))
274
275 ;;; Asynchronous eval
276
277 (defun guess-package-from-string (name)
278 (or (and name
279 (or (find-package name)
280 (find-package (string-upcase name))))
281 *package*))
282
283 (defvar *swank-debugger-condition*)
284 (defvar *swank-debugger-hook*)
285
286 (defvar *buffer-package*)
287
288 (defun read-string (string)
289 (let ((*package* *buffer-package*))
290 (read-from-string string)))
291
292 (defun swank-debugger-hook (condition hook)
293 (send-to-emacs '(:debugger-hook))
294 (let ((*swank-debugger-condition* condition)
295 (*swank-debugger-hook* hook))
296 (read-from-emacs)))
297
298 (defun eval-string (string package-name)
299 (let ((*debugger-hook* #'swank-debugger-hook))
300 (let (ok result)
301 (unwind-protect
302 (let ((*buffer-package* (guess-package-from-string package-name)))
303 (setq result (eval (read-string string)))
304 (setq ok t))
305 (send-to-emacs (if ok `(:ok ,result) '(:aborted)))))))
306
307 (defun swank-compile-string (string buffer start)
308 (let ((*package* *buffer-package*))
309 (with-input-from-string (stream string)
310 (multiple-value-list
311 (ext:compile-from-stream stream :source-info (cons buffer start))))))
312
313 (defun briefly-describe-symbol-for-emacs (symbol)
314 "Return a plist of describing SYMBOL.
315 Return NIL if the symbol is unbound."
316 (let ((result '()))
317 (labels ((first-line (string)
318 (let ((pos (position #\newline string)))
319 (if (null pos) string (subseq string 0 pos))))
320 (doc (kind)
321 (let ((string (documentation symbol kind)))
322 (if string
323 (first-line string)
324 :not-documented)))
325 (maybe-push (property value)
326 (when value
327 (setf result (list* property value result)))))
328 (maybe-push
329 :variable (multiple-value-bind (kind recorded-p)
330 (ext:info variable kind symbol)
331 (declare (ignore kind))
332 (if (or (boundp symbol) recorded-p)
333 (doc 'variable))))
334 (maybe-push
335 :function (if (fboundp symbol)
336 (doc 'function)))
337 (maybe-push
338 :setf (if (or (ext:info setf inverse symbol)
339 (ext:info setf expander symbol))
340 (doc 'setf)))
341 (maybe-push
342 :type (if (ext:info type kind symbol)
343 (doc 'type)))
344 (maybe-push
345 :class (if (find-class symbol nil)
346 (doc 'class)))
347 (if result
348 (list* :designator (prin1-to-string symbol) result)))))
349
350 (defun apropos-list-for-emacs (name &optional external-only package)
351 "Make an apropos search for Emacs.
352 The result is a list of property lists."
353 (mapcan (listify #'briefly-describe-symbol-for-emacs)
354 (sort (apropos-symbols name external-only package)
355 #'belongs-before-in-apropos-p)))
356
357 (defun listify (f)
358 "Return a function like F, but which returns any non-null value
359 wrapped in a list."
360 (lambda (x)
361 (let ((y (funcall f x)))
362 (and y (list y)))))
363
364 (defun apropos-symbols (string &optional external-only package)
365 "Return the symbols matching an apropos search."
366 (let ((symbols '()))
367 (ext:map-apropos (lambda (sym)
368 (unless (keywordp sym)
369 (push sym symbols)))
370 string package external-only)
371 symbols))
372
373 (defun belongs-before-in-apropos-p (a b)
374 "Return true if A belongs before B in an apropos listing.
375 Sorted alphabetically by package name and then symbol name, except
376 that symbols accessible in the current package go first."
377 (flet ((accessible (s)
378 (find-symbol (symbol-name s) *package*)))
379 (let ((pa (symbol-package a))
380 (pb (symbol-package b)))
381 (cond ((or (eq pa pb)
382 (and (accessible a) (accessible b)))
383 (string< (symbol-name a) (symbol-name b)))
384 ((accessible a) t)
385 ((accessible b) nil)
386 (t
387 (string< (package-name pa) (package-name pb)))))))
388
389 (defun set-stdin-non-blocking ()
390 (let ((fd (sys:fd-stream-fd sys:*stdin*)))
391 (flet ((fcntl (fd cmd arg)
392 (multiple-value-bind (flags errno) (unix:unix-fcntl fd cmd arg)
393 (or flags
394 (error "fcntl: ~A" (unix:get-unix-error-msg errno))))))
395 (let ((flags (fcntl fd unix:F-GETFL 0)))
396 (fcntl fd unix:F-SETFL (logior flags unix:O_NONBLOCK))))))
397
398 (set-stdin-non-blocking)
399
400
401 ;;; Debugging stuff
402
403 (defvar *sldb-level* 0)
404 (defvar *sldb-stack-top*)
405 (defvar *sldb-restarts*)
406
407 (defun sldb-loop ()
408 (unix:unix-sigsetmask 0)
409 (let* ((*sldb-level* (1+ *sldb-level*))
410 (*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame)))
411 (*sldb-restarts* (compute-restarts *swank-debugger-condition*))
412 (debug:*stack-top-hint* nil)
413 (*debugger-hook* nil)
414 (level *sldb-level*))
415 (handler-bind ((di:debug-condition
416 (lambda (condition)
417 (send-to-emacs `(:debug-condition
418 ,(princ-to-string condition)))
419 (throw 'sldb-loop-catcher nil))))
420 (unwind-protect
421 (loop
422 (catch 'sldb-loop-catcher
423 (with-simple-restart (abort "Return to sldb level ~D." level)
424 (send-to-emacs `(:sldb-prompt ,level))
425 (read-from-emacs))))
426 (send-to-emacs `(:sldb-abort ,level))))))
427
428 (defun format-restarts-for-emacs ()
429 "Return a list of restarts for *swank-debugger-condition* in a
430 format suitable for Emacs."
431 (loop for restart in *sldb-restarts*
432 collect (list (princ-to-string (restart-name restart))
433 (princ-to-string restart))))
434
435 (defun format-condition-for-emacs ()
436 (format nil "~A~% [Condition of type ~S]"
437 (debug::safe-condition-message *swank-debugger-condition*)
438 (type-of *swank-debugger-condition*)))
439
440 (defun nth-frame (index)
441 (do ((frame *sldb-stack-top* (di:frame-down frame))
442 (i index (1- i)))
443 ((zerop i) frame)))
444
445 (defun nth-restart (index)
446 (nth index *sldb-restarts*))
447
448 (defun format-frame-for-emacs (frame)
449 (list (di:frame-number frame)
450 (with-output-to-string (*standard-output*)
451 (debug::print-frame-call frame :verbosity 1 :number t))))
452
453 (defun backtrace-length ()
454 "Return the number of frames on the stack."
455 (do ((frame *sldb-stack-top* (di:frame-down frame))
456 (i 0 (1+ i)))
457 ((not frame) i)))
458
459 (defun compute-backtrace (start end)
460 "Return a list of frames staring with frame number START and
461 continueing to END or if END is nil the last frame on the stack."
462 (let ((end (or end most-positive-fixnum)))
463 (do ((frame *sldb-stack-top* (di:frame-down frame))
464 (i 0 (1+ i)))
465 ((= i start)
466 (loop for f = frame then (di:frame-down f)
467 for i from start below end
468 while f
469 collect f)))))
470
471 (defun backtrace-for-emacs (start end)
472 (mapcar #'format-frame-for-emacs (compute-backtrace start end)))
473
474 (defun debugger-info-for-emacs (start end)
475 (list (format-condition-for-emacs)
476 (format-restarts-for-emacs)
477 (backtrace-length)
478 (backtrace-for-emacs start end)))
479
480 (defun code-location-source-path (code-location)
481 (let* ((location (debug::maybe-block-start-location code-location))
482 (form-num (di:code-location-form-number location)))
483 (let ((translations (debug::get-top-level-form location)))
484 (unless (< form-num (length translations))
485 (error "Source path no longer exists."))
486 (reverse (cdr (svref translations form-num))))))
487
488 (defun code-location-file-position (code-location)
489 (let* ((debug-source (di:code-location-debug-source code-location))
490 (filename (di:debug-source-name debug-source))
491 (path (code-location-source-path code-location)))
492 (source-path-file-position path filename)))
493
494 (defun source-path-file-position (path filename)
495 (let ((*read-suppress* t))
496 (with-open-file (file filename)
497 (dolist (n path)
498 (dotimes (i n)
499 (read file))
500 (read-delimited-list #\( file))
501 (let ((start (file-position file)))
502 (file-position file (1- start))
503 (read file)
504 (list start (file-position file))))))
505
506 (defun code-location-for-emacs (code-location)
507 (let* ((debug-source (di:code-location-debug-source code-location))
508 (from (di:debug-source-from debug-source))
509 (name (di:debug-source-name debug-source)))
510 (list
511 :from from
512 :filename (if (eq from :file)
513 (ext:unix-namestring (truename name)))
514 :position (if (eq from :file)
515 (code-location-file-position code-location))
516 :source-form
517 (if (not (eq from :file))
518 (with-output-to-string (*standard-output*)
519 (debug::print-code-location-source-form code-location 100 t))))))
520
521 (defun safe-code-location-for-emacs (code-location)
522 (handler-case (code-location-for-emacs code-location)
523 (t (c) (list :error (debug::safe-condition-message c)))))
524
525 (defun frame-code-location-for-emacs (index)
526 (safe-code-location-for-emacs (di:frame-code-location (nth-frame index))))
527
528 (defun eval-string-in-frame (string index)
529 (prin1-to-string
530 (di:eval-in-frame (nth-frame index) (read-string string))))
531
532 (defun frame-locals (index)
533 (let* ((frame (nth-frame index))
534 (location (di:frame-code-location frame))
535 (debug-function (di:frame-debug-function frame))
536 (debug-variables (di:ambiguous-debug-variables debug-function "")))
537 (loop for v in debug-variables
538 collect (list
539 :symbol (di:debug-variable-symbol v)
540 :id (di:debug-variable-id v)
541 :validity (di:debug-variable-validity v location)
542 :value-string
543 (prin1-to-string (di:debug-variable-value v frame))))))
544
545 (defun frame-catch-tags (index)
546 (loop for (tag . code-location) in (di:frame-catches (nth-frame index))
547 collect `(,tag . ,(safe-code-location-for-emacs code-location))))
548
549 (defun invoke-nth-restart (index)
550 (invoke-restart (nth-restart index)))
551
552 (defun sldb-abort ()
553 (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
554
555 (defun throw-to-toplevel ()
556 (throw 'lisp::top-level-catcher nil))

  ViewVC Help
Powered by ViewVC 1.1.5