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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Thu Sep 11 16:08:10 2003 UTC (10 years, 7 months ago) by lukeg
Branch: MAIN
Changes since 1.4: +7 -0 lines
(symbol-external-p): Put back this function which was lost in a merge.
1 (defpackage :swank
2 (:use :common-lisp :wire)
3 (:export #:start-server #:evaluate #:lookup-notes #:clear-notes
4 #:swank-compile-file #:swank-compile-string
5 #:arglist-string #:completions
6 #:find-fdefinition))
7
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 (send-value (eval (let ((debug::*debugger-hook* #'debugger-hook)
90 (*package* (find-package package)))
91 (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 ""))
98 (error (condition)
99 (send-and-log-internal-error condition))))
100
101 ;;;; SWANK-COMPILE-FILE -- interface
102
103 (defun swank-compile-file (filename load-p)
104 (clear-notes filename)
105 (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 (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 (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 (defun canonicalize-filename (filename)
156 (namestring (unix:unix-resolve-links filename)))
157
158 (defun lookup-notes (filename)
159 "Return the compiler notes recorded for FILENAME.
160 \(See *NOTES-DATABASE* for a description of the return type.)"
161 (gethash (canonicalize-filename filename) *notes-database*))
162
163 (defun clear-notes (filename)
164 (remhash (canonicalize-filename filename) *notes-database*))
165
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 (defun completions (prefix package-name &optional only-external-p)
198 "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 (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 completions))
209
210 (defun symbol-external-p (s)
211 (multiple-value-bind (_ status)
212 (find-symbol (symbol-name s) (symbol-package s))
213 (declare (ignore _))
214 (eq status :external)))
215
216
217 (defun string-prefix-p (s1 s2)
218 "Return true iff the string S1 is a prefix of S2.
219 \(This includes the case where S1 is equal to S2.)"
220 (and (<= (length s1) (length s2))
221 (string= s1 s2 :end2 (length s1))))
222
223 ;;;; Definitions
224
225 ;;; FIND-FDEFINITION -- interface
226 ;;;
227 (defun find-fdefinition (symbol-name package-name)
228 "Return the name of the file in which the function was defined, or NIL."
229 (fdefinition-file (read-symbol/package symbol-name package-name)))
230
231 ;;; Clone of HEMLOCK-INTERNALS::FUN-DEFINED-FROM-PATHNAME
232 (defun fdefinition-file (function)
233 "Return the name of the file in which FUNCTION was defined."
234 (declare (type (or symbol function) function))
235 (typecase function
236 (symbol
237 (let ((def (or (macro-function function)
238 (and (fboundp function)
239 (fdefinition function)))))
240 (when def (fdefinition-file def))))
241 (kernel:byte-closure
242 (fdefinition-file (kernel:byte-closure-function function)))
243 (kernel:byte-function
244 (code-definition-file (c::byte-function-component function)))
245 (function
246 (code-definition-file (kernel:function-code-header
247 (kernel:%function-self function))))
248 (t nil)))
249
250 (defun code-definition-file (code)
251 "Return the name of the file in which CODE was defined."
252 (declare (type kernel:code-component code))
253 (flet ((to-namestring (pathname)
254 (handler-case (namestring (truename pathname))
255 (file-error () nil))))
256 (let ((info (kernel:%code-debug-info code)))
257 (when info
258 (let ((source (car (c::debug-info-source info))))
259 (when (and source (eq (c::debug-source-from source) :file))
260 (to-namestring (c::debug-source-name source))))))))
261
262 ;;;; Utilities.
263
264 (defun read-symbol/package (symbol-name package-name)
265 (let ((package (find-package package-name)))
266 (unless package (error "No such package: %S" package-name))
267 (handler-case
268 (let ((*package* package))
269 (read-from-string symbol-name))
270 (reader-error () nil))))
271
272 ;;; Asynchronous eval
273
274 (defun guess-package-from-string (name)
275 (or (and name
276 (or (find-package name)
277 (find-package (string-upcase name))))
278 *package*))
279
280 (defun read-catch-errors (string)
281 (let (form (error nil))
282 (handler-case
283 (setq form (read-from-string string))
284 (t (condition) (setq error (princ-to-string condition))))
285 (values form error)))
286
287 (defun send-to-emacs (object)
288 (wire-output-object *current-wire* object)
289 (wire-force-output *current-wire*))
290
291 (defvar *swank-debugger-condition*)
292 (defvar *swank-debugger-hook*)
293
294 (defun eval-string-async (string package-name id)
295 (let ((*package* (guess-package-from-string package-name)))
296 (multiple-value-bind (form error) (read-catch-errors string)
297 (if error
298 (send-to-emacs `(:CALL-CONTINUATION ,id (:READ-FAILED ,error)))
299 (let ((*debugger-hook*
300 (lambda (condition hook)
301 (send-to-emacs `(:DEBUGGER-HOOK
302 ,debug::*debug-command-level*))
303 (let ((*swank-debugger-condition* condition)
304 (*swank-debugger-hook* hook))
305 (wire-get-object *current-wire*)))))
306 (let (ok result)
307 (unwind-protect
308 (progn (setq result (eval form))
309 (setq ok t))
310 (if ok
311 (send-to-emacs `(:CALL-CONTINUATION ,id
312 (:OK ,result)))
313 (send-to-emacs `(:CALL-CONTINUATION ,id (:ABORTED)))))))))))
314
315 (defun briefely-describe-symbol-for-emacs (symbol)
316 "Return a plist of describing SYMBOL. Return NIL if the symbol is
317 unbound."
318 (let ((result '()))
319 (labels ((first-line (string)
320 (subseq string 0 (position #\newline string)))
321 (doc (kind)
322 (let ((string (documentation symbol kind)))
323 (if string
324 (first-line string)
325 :not-documented)))
326 (maybe-push (property value)
327 (when value
328 (setf result (list* property value result)))))
329 (maybe-push
330 :variable (multiple-value-bind (kind recorded-p)
331 (ext:info variable kind symbol)
332 (declare (ignore kind))
333 (if (or (boundp symbol) recorded-p)
334 (doc 'variable))))
335 (maybe-push
336 :function (if (fboundp symbol)
337 (doc 'function)))
338 (maybe-push
339 :setf (if (or (ext:info setf inverse symbol)
340 (ext:info setf expander symbol))
341 (doc 'setf)))
342 (maybe-push
343 :type (if (ext:info type kind symbol)
344 (doc 'type)))
345 (maybe-push
346 :class (if (find-class symbol nil)
347 (doc 'class)))
348 (if result
349 (list* :designator (prin1-to-string symbol) result)))))
350
351 (defun apropos-list-for-emacs (name)
352 (list (package-name *package*)
353 (ext:collect ((pack))
354 (ext:map-apropos
355 (lambda (symbol)
356 (unless (keywordp symbol)
357 (let ((plist (briefely-describe-symbol-for-emacs symbol)))
358 (when plist
359 (pack plist)))))
360 name)
361 (pack))))
362
363 (defun set-stdin-non-blocking ()
364 (let ((fd (sys:fd-stream-fd sys:*stdin*)))
365 (flet ((fcntl (fd cmd arg)
366 (multiple-value-bind (flags errno) (unix:unix-fcntl fd cmd arg)
367 (or flags
368 (error "fcntl: ~A" (unix:get-unix-error-msg errno))))))
369 (let ((flags (fcntl fd unix:F-GETFL 0)))
370 (fcntl fd unix:F-SETFL (logior flags unix:O_NONBLOCK))))))
371
372 (set-stdin-non-blocking)
373

  ViewVC Help
Powered by ViewVC 1.1.5