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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (hide annotations)
Wed Sep 10 19:33:44 2003 UTC (10 years, 7 months ago) by lukeg
Branch: MAIN
Changes since 1.3: +121 -14 lines
Large patch from Helmut Eller. Includes: apropos, describe,
compile-defun, fully asynchronous continuation-based wire interface,
interactive evaluation, and more. Very nice :-)
1 lukeg 1.1 (defpackage :swank
2     (:use :common-lisp :wire)
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.3 #:find-fdefinition))
7 lukeg 1.1
8     (in-package :swank)
9    
10     (defconstant server-port 4004
11     "Default port for the swank TCP server.")
12    
13     (defconstant +internal-error+ 56)
14     (defconstant +condition+ 57)
15     (defconstant +ok+ 42)
16    
17     (define-condition swank-error (simple-error) ())
18    
19     (defvar *notes-database* (make-hash-table :test #'equal)
20     "Database of recorded compiler notes/warnings/erros (keyed by filename).
21     Each value is a list of (LOCATION SEVERITY MESSAGE CONTEXT) lists.
22     LOCATION is a position in the source code (integer or source path).
23     SEVERITY is one of :ERROR, :WARNING, and :NOTE.
24     MESSAGE is a string describing the note.
25     CONTEXT is a string giving further details of where the error occured.")
26    
27     (defvar *swank-debug-p* nil
28     "When true extra debug printouts are enabled.")
29    
30     ;;; Setup and hooks.
31    
32     (defun start-server (&optional (port server-port))
33     (wire:create-request-server port nil :reuse-address t)
34     (setf c:*record-xref-info* t)
35     (ext:without-package-locks
36     (setf c:*compiler-notification-function* #'handle-notification))
37     (when *swank-debug-p*
38     (format *debug-io* "~&Swank ready.~%")))
39    
40     (defun debugger-hook (condition old-hook)
41     "Hook function to be invoked instead of the debugger.
42     See CL:*DEBUGGER-HOOK*."
43     ;; FIXME: Debug from Emacs!
44     (declare (ignore old-hook))
45     (handler-case
46     (progn (format *error-output*
47     "~@<SWANK: unhandled condition ~2I~_~A~:>~%"
48     condition)
49     (debug:backtrace 20 *error-output*)
50     (finish-output *error-output*))
51     (condition ()
52     nil)))
53    
54     (defun handle-notification (severity message context where-from position)
55     "Hook function called by the compiler.
56     See C:*COMPILER-NOTIFICATION-FUNCTION*"
57     (let ((location (or (current-compiler-error-source-path) position))
58     (namestring (cond ((stringp where-from) where-from)
59     ;; we can be passed a stream from READER-ERROR
60     ((lisp::fd-stream-p where-from)
61     (lisp::fd-stream-file where-from))
62     (t where-from))))
63     (when namestring
64     (push (list location severity message context)
65     (gethash namestring *notes-database*)))))
66    
67     (defun current-compiler-error-source-path ()
68     "Return the source-path for the current compiler error.
69     Returns NIL if this cannot be determined by examining internal
70     compiler state."
71     (let ((context c::*compiler-error-context*))
72     (cond ((c::node-p context)
73     (reverse
74     (c::source-path-original-source (c::node-source-path context))))
75     ((c::compiler-error-context-p context)
76     (reverse
77     (c::compiler-error-context-original-source-path context))))))
78    
79     ;;; Functions for Emacs to call.
80    
81     ;;;; EVALUATE -- interface
82    
83     (defun evaluate (string package)
84     "Evaluate an expression for Emacs."
85     (declare (type simple-string string))
86     (when *swank-debug-p*
87     (format *debug-io* "~&;; SWANK:EVALUATE (~S) |~S|~%" package string))
88     (handler-case
89 lukeg 1.2 (send-value (eval (let ((debug::*debugger-hook* #'debugger-hook)
90     (*package* (find-package package)))
91 lukeg 1.1 (read-from-string string))))
92     (swank-error (condition)
93     (send-reply +condition+
94     (format nil
95     (simple-condition-format-control condition)
96     (simple-condition-format-arguments condition))
97 lukeg 1.4 ""))
98     (error (condition)
99     (send-and-log-internal-error condition))))
100 lukeg 1.1
101     ;;;; SWANK-COMPILE-FILE -- interface
102    
103     (defun swank-compile-file (filename load-p)
104 lukeg 1.4 (clear-notes filename)
105 lukeg 1.1 (if (not (probe-file filename))
106     (send-reply +condition+ "File does not exist" "")
107     (handler-case
108     (multiple-value-bind (output warnings failure)
109     (compile-file filename :load (read-from-string load-p))
110     (send-value (list (and output (namestring output))
111     warnings
112     failure)))
113     (reader-error (condition)
114     (send-condition condition))
115     (end-of-file (condition)
116     (send-condition condition))
117     (package-error (condition)
118     (send-condition condition))
119     (c::compiler-error (condition)
120     (send-condition condition (current-compiler-error-source-path)))
121     (error (condition)
122     (format *debug-io* "~&Condition: ~S / ~S~%" (type-of condition) condition)
123     ;; Oops.
124     (send-and-log-internal-error condition)))))
125    
126 lukeg 1.4 (defun swank-compile-string (string buffer start)
127     (with-input-from-string (stream string)
128     (multiple-value-list
129     (ext:compile-from-stream stream :source-info (cons buffer start)))))
130    
131 lukeg 1.1 (defun send-reply (status message result)
132     "Send a result triple over the wire to Emacs."
133     (declare (type integer status))
134     (when *swank-debug-p*
135     (format *debug-io* "~&;; SWANK Reply: ~S, ~S, ~S~%" status message result))
136     (wire-output-object *current-wire* status)
137     (wire-output-object *current-wire* message)
138     (wire-output-object *current-wire* result)
139     (wire-force-output *current-wire*))
140    
141     (defun send-value (value)
142     (send-reply +ok+ "ok" (prin1-to-string value)))
143    
144     (defun send-condition (condition &optional result)
145     (send-reply +condition+ (princ-to-string condition) (prin1-to-string result)))
146    
147     (defun send-and-log-internal-error (condition)
148     (format *debug-io* "~&Internal Swank Error: ~A~%" condition)
149     (send-reply +internal-error+
150     (format nil "~&Internal Swank Error: ~A~%" condition)
151     ""))
152    
153     ;;;; LOOKUP-NOTES -- interface
154    
155 lukeg 1.4 (defun canonicalize-filename (filename)
156     (namestring (unix:unix-resolve-links filename)))
157    
158 lukeg 1.1 (defun lookup-notes (filename)
159     "Return the compiler notes recorded for FILENAME.
160     \(See *NOTES-DATABASE* for a description of the return type.)"
161 lukeg 1.4 (gethash (canonicalize-filename filename) *notes-database*))
162    
163     (defun clear-notes (filename)
164     (remhash (canonicalize-filename filename) *notes-database*))
165 lukeg 1.1
166     ;;;; ARGLIST-STRING -- interface
167     (defun arglist-string (function)
168     "Return a string describing the argument list for FUNCTION.
169     The result has the format \"(...)\"."
170     (declare (type (or symbol function) function))
171     (let ((arglist
172     (if (not (or (fboundp function)
173     (functionp function)))
174     "(-- <Unknown-Function>)"
175     (let* ((fun (etypecase function
176     (symbol (or (macro-function function)
177     (symbol-function function)))
178     (function function)))
179     (df (di::function-debug-function fun))
180     (arglist (kernel:%function-arglist fun)))
181     (cond ((eval:interpreted-function-p fun)
182     (eval:interpreted-function-arglist fun))
183     ((pcl::generic-function-p fun)
184     (pcl::gf-pretty-arglist fun))
185     (arglist arglist)
186     ;; this should work both for
187     ;; compiled-debug-function and for
188     ;; interpreted-debug-function
189     (df (di::debug-function-lambda-list df))
190     (t "(<arglist-unavailable>)"))))))
191     (if (stringp arglist)
192     arglist
193     (prin1-to-string arglist))))
194    
195     ;;;; COMPLETIONS -- interface
196    
197 lukeg 1.2 (defun completions (prefix package-name &optional only-external-p)
198 lukeg 1.1 "Return a list of completions for a symbol's PREFIX and PACKAGE-NAME.
199     The result is a list of symbol-name strings. All symbols accessible in
200     the package are considered."
201 lukeg 1.2 (let ((completions nil)
202     (package (find-package package-name)))
203     (when package
204     (do-symbols (symbol package)
205     (when (and (or (not only-external-p) (symbol-external-p symbol))
206     (string-prefix-p prefix (symbol-name symbol)))
207     (push (symbol-name symbol) completions))))
208 lukeg 1.1 completions))
209 lukeg 1.2
210 lukeg 1.1 (defun string-prefix-p (s1 s2)
211     "Return true iff the string S1 is a prefix of S2.
212     \(This includes the case where S1 is equal to S2.)"
213     (and (<= (length s1) (length s2))
214     (string= s1 s2 :end2 (length s1))))
215 lukeg 1.3
216     ;;;; Definitions
217    
218     ;;; FIND-FDEFINITION -- interface
219     ;;;
220     (defun find-fdefinition (symbol-name package-name)
221     "Return the name of the file in which the function was defined, or NIL."
222     (fdefinition-file (read-symbol/package symbol-name package-name)))
223    
224     ;;; Clone of HEMLOCK-INTERNALS::FUN-DEFINED-FROM-PATHNAME
225     (defun fdefinition-file (function)
226     "Return the name of the file in which FUNCTION was defined."
227     (declare (type (or symbol function) function))
228     (typecase function
229     (symbol
230     (let ((def (or (macro-function function)
231     (and (fboundp function)
232     (fdefinition function)))))
233     (when def (fdefinition-file def))))
234     (kernel:byte-closure
235     (fdefinition-file (kernel:byte-closure-function function)))
236     (kernel:byte-function
237     (code-definition-file (c::byte-function-component function)))
238     (function
239     (code-definition-file (kernel:function-code-header
240     (kernel:%function-self function))))
241     (t nil)))
242    
243     (defun code-definition-file (code)
244     "Return the name of the file in which CODE was defined."
245     (declare (type kernel:code-component code))
246     (flet ((to-namestring (pathname)
247     (handler-case (namestring (truename pathname))
248     (file-error () nil))))
249     (let ((info (kernel:%code-debug-info code)))
250     (when info
251     (let ((source (car (c::debug-info-source info))))
252     (when (and source (eq (c::debug-source-from source) :file))
253     (to-namestring (c::debug-source-name source))))))))
254    
255     ;;;; Utilities.
256    
257     (defun read-symbol/package (symbol-name package-name)
258     (let ((package (find-package package-name)))
259     (unless package (error "No such package: %S" package-name))
260     (handler-case
261     (let ((*package* package))
262     (read-from-string symbol-name))
263     (reader-error () nil))))
264 lukeg 1.4
265     ;;; Asynchronous eval
266    
267     (defun guess-package-from-string (name)
268     (or (and name
269     (or (find-package name)
270     (find-package (string-upcase name))))
271     *package*))
272    
273     (defun read-catch-errors (string)
274     (let (form (error nil))
275     (handler-case
276     (setq form (read-from-string string))
277     (t (condition) (setq error (princ-to-string condition))))
278     (values form error)))
279    
280     (defun send-to-emacs (object)
281     (wire-output-object *current-wire* object)
282     (wire-force-output *current-wire*))
283    
284     (defvar *swank-debugger-condition*)
285     (defvar *swank-debugger-hook*)
286    
287     (defun eval-string-async (string package-name id)
288     (let ((*package* (guess-package-from-string package-name)))
289     (multiple-value-bind (form error) (read-catch-errors string)
290     (if error
291     (send-to-emacs `(:CALL-CONTINUATION ,id (:READ-FAILED ,error)))
292     (let ((*debugger-hook*
293     (lambda (condition hook)
294     (send-to-emacs `(:DEBUGGER-HOOK
295     ,debug::*debug-command-level*))
296     (let ((*swank-debugger-condition* condition)
297     (*swank-debugger-hook* hook))
298     (wire-get-object *current-wire*)))))
299     (let (ok result)
300     (unwind-protect
301     (progn (setq result (eval form))
302     (setq ok t))
303     (if ok
304     (send-to-emacs `(:CALL-CONTINUATION ,id
305     (:OK ,result)))
306     (send-to-emacs `(:CALL-CONTINUATION ,id (:ABORTED)))))))))))
307    
308     (defun briefely-describe-symbol-for-emacs (symbol)
309     "Return a plist of describing SYMBOL. Return NIL if the symbol is
310     unbound."
311     (let ((result '()))
312     (labels ((first-line (string)
313     (subseq string 0 (position #\newline string)))
314     (doc (kind)
315     (let ((string (documentation symbol kind)))
316     (if string
317     (first-line string)
318     :not-documented)))
319     (maybe-push (property value)
320     (when value
321     (setf result (list* property value result)))))
322     (maybe-push
323     :variable (multiple-value-bind (kind recorded-p)
324     (ext:info variable kind symbol)
325     (declare (ignore kind))
326     (if (or (boundp symbol) recorded-p)
327     (doc 'variable))))
328     (maybe-push
329     :function (if (fboundp symbol)
330     (doc 'function)))
331     (maybe-push
332     :setf (if (or (ext:info setf inverse symbol)
333     (ext:info setf expander symbol))
334     (doc 'setf)))
335     (maybe-push
336     :type (if (ext:info type kind symbol)
337     (doc 'type)))
338     (maybe-push
339     :class (if (find-class symbol nil)
340     (doc 'class)))
341     (if result
342     (list* :designator (prin1-to-string symbol) result)))))
343    
344     (defun apropos-list-for-emacs (name)
345     (list (package-name *package*)
346     (ext:collect ((pack))
347     (ext:map-apropos
348     (lambda (symbol)
349     (unless (keywordp symbol)
350     (let ((plist (briefely-describe-symbol-for-emacs symbol)))
351     (when plist
352     (pack plist)))))
353     name)
354     (pack))))
355    
356     (defun set-stdin-non-blocking ()
357     (let ((fd (sys:fd-stream-fd sys:*stdin*)))
358     (flet ((fcntl (fd cmd arg)
359     (multiple-value-bind (flags errno) (unix:unix-fcntl fd cmd arg)
360     (or flags
361     (error "fcntl: ~A" (unix:get-unix-error-msg errno))))))
362     (let ((flags (fcntl fd unix:F-GETFL 0)))
363     (fcntl fd unix:F-SETFL (logior flags unix:O_NONBLOCK))))))
364    
365     (set-stdin-non-blocking)
366 lukeg 1.1

  ViewVC Help
Powered by ViewVC 1.1.5