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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (hide 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 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 ellerh 1.7 #:eval-string
8 lukeg 1.6 #: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 ellerh 1.7 (defvar *swank-debug-p* t
24 lukeg 1.1 "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 ellerh 1.7 (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 lukeg 1.6 (let* ((length (logior (ash (read-byte *emacs-io*) 16)
117 ellerh 1.7 (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 lukeg 1.6
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 ellerh 1.7 (let ((*print-case* :downcase)
150     (*print-readably* t)
151     (*print-pretty* nil)
152     (*package* *swank-io-package*))
153     (prin1-to-string object)))
154    
155 lukeg 1.6 ;;; Functions for Emacs to call.
156 lukeg 1.1
157     ;;;; LOOKUP-NOTES -- interface
158    
159 lukeg 1.4 (defun canonicalize-filename (filename)
160     (namestring (unix:unix-resolve-links filename)))
161    
162 lukeg 1.1 (defun lookup-notes (filename)
163     "Return the compiler notes recorded for FILENAME.
164     \(See *NOTES-DATABASE* for a description of the return type.)"
165 lukeg 1.4 (gethash (canonicalize-filename filename) *notes-database*))
166    
167     (defun clear-notes (filename)
168     (remhash (canonicalize-filename filename) *notes-database*))
169 lukeg 1.1
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 lukeg 1.6 (prin1-to-string-for-emacs arglist))))
198 lukeg 1.1
199     ;;;; COMPLETIONS -- interface
200    
201 lukeg 1.2 (defun completions (prefix package-name &optional only-external-p)
202 lukeg 1.1 "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 lukeg 1.2 (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 lukeg 1.1 completions))
213 lukeg 1.2
214 lukeg 1.5 (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 lukeg 1.1 (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 lukeg 1.3
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 ellerh 1.7 (unless package (error "No such package: ~S" package-name))
270 lukeg 1.3 (handler-case
271     (let ((*package* package))
272     (read-from-string symbol-name))
273     (reader-error () nil))))
274 lukeg 1.4
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 ellerh 1.7 (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 lukeg 1.4
313 lukeg 1.8 (defun briefly-describe-symbol-for-emacs (symbol)
314     "Return a plist of describing SYMBOL.
315     Return NIL if the symbol is unbound."
316 lukeg 1.4 (let ((result '()))
317     (labels ((first-line (string)
318 lukeg 1.8 (let ((pos (position #\newline string)))
319     (if (null pos) string (subseq string 0 pos))))
320 lukeg 1.4 (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 lukeg 1.8 (list* :designator (prin1-to-string symbol) result)))))
349 lukeg 1.4
350 lukeg 1.8 (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 lukeg 1.4
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 lukeg 1.1
400 lukeg 1.6
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 ellerh 1.7 (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 lukeg 1.6
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 ellerh 1.7 (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 lukeg 1.6
448     (defun format-frame-for-emacs (frame)
449     (list (di:frame-number frame)
450     (with-output-to-string (*standard-output*)
451 ellerh 1.7 (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 lukeg 1.6
471     (defun backtrace-for-emacs (start end)
472 ellerh 1.7 (mapcar #'format-frame-for-emacs (compute-backtrace start end)))
473 lukeg 1.6
474     (defun debugger-info-for-emacs (start end)
475     (list (format-condition-for-emacs)
476     (format-restarts-for-emacs)
477 ellerh 1.7 (backtrace-length)
478 lukeg 1.6 (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 ellerh 1.7 (defun code-location-for-emacs (code-location)
507     (let* ((debug-source (di:code-location-debug-source code-location))
508 lukeg 1.6 (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 ellerh 1.7 (if (not (eq from :file))
518     (with-output-to-string (*standard-output*)
519     (debug::print-code-location-source-form code-location 100 t))))))
520 lukeg 1.6
521 ellerh 1.7 (defun safe-code-location-for-emacs (code-location)
522     (handler-case (code-location-for-emacs code-location)
523 lukeg 1.6 (t (c) (list :error (debug::safe-condition-message c)))))
524 ellerh 1.7
525     (defun frame-code-location-for-emacs (index)
526     (safe-code-location-for-emacs (di:frame-code-location (nth-frame index))))
527    
528 lukeg 1.6 (defun eval-string-in-frame (string index)
529 ellerh 1.7 (prin1-to-string
530     (di:eval-in-frame (nth-frame index) (read-string string))))
531 lukeg 1.6
532 ellerh 1.7 (defun frame-locals (index)
533 lukeg 1.6 (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 ellerh 1.7 (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 lukeg 1.6
549     (defun invoke-nth-restart (index)
550     (invoke-restart (nth-restart index)))
551    
552 ellerh 1.7 (defun sldb-abort ()
553     (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
554    
555     (defun throw-to-toplevel ()
556 lukeg 1.6 (throw 'lisp::top-level-catcher nil))

  ViewVC Help
Powered by ViewVC 1.1.5