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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (hide 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 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.5 (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 lukeg 1.1 (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 lukeg 1.3
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 lukeg 1.4
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 lukeg 1.1

  ViewVC Help
Powered by ViewVC 1.1.5