Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 412 lines (353 sloc) 14.033 kb
cc43d38 First version.
Helmut Eller authored
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; swank-lispworks.lisp --- LispWorks specific code for SLIME.
4 ;;;
5 ;;; Created 2003, Helmut Eller
6 ;;;
7 ;;; This code has been placed in the Public Domain. All warranties
8 ;;; are disclaimed.
9 ;;;
10 ;;; $Id$
11 ;;;
12
13 (in-package :swank)
14
15 (eval-when (:compile-toplevel :load-toplevel :execute)
16 (require "comm"))
17
18 (import
19 '(stream:fundamental-character-output-stream
20 stream:stream-write-char
21 stream:stream-force-output
22 stream:fundamental-character-input-stream
23 stream:stream-read-char
24 stream:stream-listen
25 stream:stream-unread-char
26 stream:stream-clear-input
27 stream:stream-line-column
28 ))
29
30 (defun without-interrupts* (body)
31 (lispworks:without-interrupts (funcall body)))
32
33 (defun create-swank-server (port &key reuse-address)
34 "Create a Swank TCP server on `port'.
35 Return the port number that the socket is actually listening on."
36 (declare (ignore reuse-address))
37 (comm:start-up-server-and-mp :announce *terminal-io* :service port
38 :process-name "Swank Request Processor"
39 :function 'swank-accept-connection
40 )
41 port)
42
43 (defconstant +sigint+ 2)
44
45 (defun sigint-handler (&rest args)
46 (declare (ignore args))
47 (invoke-debugger "SIGINT"))
48
49 (defun swank-accept-connection (fd)
50 "Accept one Swank TCP connection on SOCKET and then close it.
51 Run the connection handler in a new thread."
52 (let ((*emacs-io* (make-instance 'comm:socket-stream
53 :socket fd
54 :direction :io
55 :element-type 'base-char)))
56 (sys:set-signal-handler +sigint+ #'sigint-handler)
57 (request-loop)))
58
59 (defun request-loop ()
60 "Thread function for a single Swank connection. Processes requests
61 until the remote Emacs goes away."
62 (unwind-protect
63 (let* ((*slime-output* (make-instance 'slime-output-stream))
64 (*slime-input* (make-instance 'slime-input-stream))
65 (*slime-io* (make-two-way-stream *slime-input* *slime-output*)))
66 (loop
67 (catch 'slime-toplevel
68 (with-simple-restart (abort "Return to Slime event loop.")
69 (handler-case (read-from-emacs)
70 (slime-read-error (e)
71 (when *swank-debug-p*
72 (format *debug-io*
73 "~&;; Connection to Emacs lost.~%;; [~A]~%" e))
74 (return)))))))
75 (format *terminal-io* "~&;; Swank: Closed connection: ~A~%" *emacs-io*)
76 (close *emacs-io*)))
77
78 (defslimefun getpid ()
79 "Return the process ID of this superior Lisp."
80 (system::getpid))
81
82 (defmethod arglist-string (fname)
83 "Return the lambda list for function FNAME as a string."
84 (let ((*print-case* :downcase))
85 (multiple-value-bind (function condition)
86 (ignore-errors (values
87 (find-symbol-designator fname *buffer-package*)))
88 (when condition
89 (return-from arglist-string (format nil "(-- ~A)" condition)))
90 (let ((arglist (and (fboundp function)
91 (lispworks:function-lambda-list function))))
92 (if arglist
93 (princ-to-string arglist)
94 "(-- <Unknown-Function>)")))))
95
96 (defmethod macroexpand-all (form)
97 (walker:walk-form form))
98
99 (defmethod describe-symbol-for-emacs (symbol)
100 "Return a plist describing SYMBOL.
101 Return NIL if the symbol is unbound."
102 (let ((result '()))
103 (labels ((first-line (string)
104 (let ((pos (position #\newline string)))
105 (if (null pos) string (subseq string 0 pos))))
106 (doc (kind &optional (sym symbol))
107 (let ((string (documentation sym kind)))
108 (if string
109 (first-line string)
110 :not-documented)))
111 (maybe-push (property value)
112 (when value
113 (setf result (list* property value result)))))
114 (maybe-push
115 :variable (when (boundp symbol)
116 (doc 'variable)))
117 (maybe-push
118 :function (if (fboundp symbol)
119 (doc 'function)))
120 (maybe-push
121 :class (if (find-class symbol nil)
122 (doc 'class)))
123 (if result
124 (list* :designator (to-string symbol) result)))))
125
ed76e57 Use the new format for source locations. Implement the
Helmut Eller authored
126 (defslimefun describe-function (symbol-name)
127 (with-output-to-string (*standard-output*)
128 (let ((sym (from-string symbol-name)))
129 (cond ((fboundp sym)
130 (format t "~%(~A~{ ~A~})~%~%~:[(not documented)~;~:*~A~]~%"
131 (string-downcase sym)
132 (mapcar #'string-upcase
133 (lispworks:function-lambda-list sym))
134 (documentation sym 'function))
135 (describe (symbol-function sym)))
136 (t (format t "~S is not fbound" sym))))))
137
cc43d38 First version.
Helmut Eller authored
138 #+(or)
139 (defmethod describe-object ((sym symbol) *standard-output*)
140 (format t "~A is a symbol in package ~A." sym (symbol-package sym))
141 (when (boundp sym)
142 (format t "~%~%Value: ~A" (symbol-value sym)))
143 (let ((doc (documentation sym 'variable)))
144 (when doc
145 (format t "~%~%Variable documentation:~%~A" doc)))
146 (when (fboundp sym)
147 (format t "~%~%(~A~{ ~A~})"
148 (string-downcase sym)
149 (mapcar #'string-upcase
150 (lispworks:function-lambda-list sym))))
151 (let ((doc (documentation sym 'function)))
152 (when doc (format t "~%~%~A~%" doc))))
153
154 ;;; Debugging
155
156 (defvar *sldb-restarts*)
157
158 (defslimefun sldb-abort ()
159 (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
160
161 (defmethod call-with-debugging-environment (fn)
162 (dbg::with-debugger-stack ()
163 (let ((*sldb-restarts* (compute-restarts *swank-debugger-condition*)))
164 (funcall fn))))
165
166 (defun format-condition-for-emacs ()
167 (let ((*print-right-margin* 75)
168 (*print-pretty* t))
169 (format nil "~A~% [Condition of type ~S]"
170 *swank-debugger-condition* (type-of *swank-debugger-condition*))))
171
172 (defun format-restarts-for-emacs ()
173 (loop for restart in *sldb-restarts*
174 collect (list (princ-to-string (restart-name restart))
175 (princ-to-string restart))))
176
177 (defun interesting-frame-p (frame)
178 (or (dbg::call-frame-p frame)
179 (dbg::catch-frame-p frame)))
180
181 (defun nth-frame (index)
182 (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*)
183 (dbg::frame-next frame))
184 (i index (if (interesting-frame-p frame) (1- i) i)))
185 ((and (interesting-frame-p frame) (zerop i)) frame)
186 (assert frame)))
187
188 (defun compute-backtrace (start end)
189 (let ((end (or end most-positive-fixnum))
190 (backtrace '()))
191 (do ((frame (nth-frame start) (dbg::frame-next frame))
192 (i start))
193 ((or (not frame) (= i end)) (nreverse backtrace))
194 (when (interesting-frame-p frame)
195 (incf i)
196 (push frame backtrace)))))
197
198 (defmethod backtrace (start end)
199 (flet ((format-frame (f i)
200 (with-output-to-string (*standard-output*)
201 (let ((*print-pretty* *sldb-pprint-frames*))
202 (format t "~D: ~A" i
203 (cond ((dbg::call-frame-p f)
204 (format nil "~A ~A"
205 (dbg::call-frame-function-name f)
206 (dbg::call-frame-arglist f)))
207 (t f)))))))
208 (loop for i from start
209 for f in (compute-backtrace start end)
210 collect (list i (format-frame f i)))))
211
212 (defmethod debugger-info-for-emacs (start end)
213 (list (format-condition-for-emacs)
214 (format-restarts-for-emacs)
215 (backtrace start end)))
216
217 (defun nth-restart (index)
218 (nth index *sldb-restarts*))
219
220 (defslimefun invoke-nth-restart (index)
221 (let ((restart (nth-restart index)))
222 (invoke-restart restart)))
223
224 (defmethod frame-locals (n)
225 (let ((frame (nth-frame n)))
226 (if (dbg::call-frame-p frame)
227 (destructuring-bind (vars with)
228 (dbg::frame-locals-format-list frame #'list 75 0)
229 (declare (ignore with))
230 (loop for (name value symbol location) in vars
231 collect (list :symbol symbol :id 0
232 :value-string (princ-to-string value)))))))
233
234 (defmethod frame-catch-tags (index)
235 (declare (ignore index))
236 nil)
237
238 (defmethod frame-source-location-for-emacs (frame)
239 (let ((frame (nth-frame frame)))
240 (if (dbg::call-frame-p frame)
241 (let ((func (dbg::call-frame-function-name frame)))
242 (if func
243 (dspec-source-location func))))))
244
245 (defun dspec-source-location (dspec)
ed76e57 Use the new format for source locations. Implement the
Helmut Eller authored
246 (destructuring-bind (first) (dspec-source-locations dspec)
247 first))
248
249 (defun dspec-source-locations (dspec)
250 (let ((locations (dspec:find-dspec-locations dspec)))
cc43d38 First version.
Helmut Eller authored
251 (cond ((not locations)
252 (list :error (format nil "Cannot find source for ~S" dspec)))
253 (t
ed76e57 Use the new format for source locations. Implement the
Helmut Eller authored
254 (loop for (dspec location) in locations
255 collect (make-dspec-location dspec location))))))
cc43d38 First version.
Helmut Eller authored
256
257 (defmethod function-source-location-for-emacs (fname)
258 "Return a source position of the definition of FNAME. The
259 precise location of the definition is not available, but we are
260 able to return the file name in which the definition occurs."
261 (dspec-source-location (from-string fname)))
262
ed76e57 Use the new format for source locations. Implement the
Helmut Eller authored
263 (defslimefun find-function-locations (fname)
264 (dspec-source-locations (from-string fname)))
265
cc43d38 First version.
Helmut Eller authored
266 ;;; callers
267
268 (defun stringify-function-name-list (list)
269 (let ((*print-pretty* nil)) (mapcar #'to-string list)))
270
271 (defslimefun list-callers (symbol-name)
272 (stringify-function-name-list (hcl:who-calls (from-string symbol-name))))
273
274 ;;; Compilation
275
276 (defmethod compile-file-for-emacs (filename load-p)
277 (let ((compiler::*error-database* '()))
278 (with-compilation-unit ()
279 (compile-file filename :load load-p)
280 (signal-error-data-base compiler::*error-database*)
281 (signal-undefined-functions compiler::*unknown-functions* filename))))
282
283 (defun map-error-database (database fn)
284 (loop for (filename . defs) in database do
285 (loop for (dspec . conditions) in defs do
286 (dolist (c conditions)
287 (funcall fn filename dspec c)))))
288
289 (defun lispworks-severity (condition)
290 (cond ((not condition) :warning)
291 (t (etypecase condition
292 (simple-error :error)
293 (style-warning :warning)
294 (warning :warning)))))
295
296 (defun signal-compiler-condition (message location condition)
297 (check-type message string)
298 (signal
299 (make-instance 'compiler-condition :message message
300 :severity (lispworks-severity condition)
301 :location location
302 :original-condition condition)))
303
304 (defun compile-from-temp-file (string filename)
305 (unwind-protect
306 (progn
307 (with-open-file (s filename :direction :output :if-exists :supersede)
308 (write-string string s)
309 (finish-output s))
310 (let ((binary-filename (compile-file filename :load t)))
311 (delete-file binary-filename)))
312 (delete-file filename)))
313
97a6e80 Xref support.
Helmut Eller authored
314 (defun make-dspec-location (dspec location &optional tmpfile buffer position)
ed76e57 Use the new format for source locations. Implement the
Helmut Eller authored
315 (flet ((from-buffer-p ()
316 (and (pathnamep location) tmpfile
317 (pathname-match-p location tmpfile)))
318 (filename (pathname)
319 (multiple-value-bind (truename condition)
320 (ignore-errors (truename pathname))
321 (cond (condition
322 (return-from make-dspec-location
323 (list :error (format nil "~A" condition))))
324 (t (namestring truename)))))
325 (function-name (dspec)
326 (etypecase dspec
327 (symbol (symbol-name dspec))
328 (cons (symbol-name (dspec:dspec-primary-name dspec))))))
329 (cond ((from-buffer-p)
330 (make-location `(:buffer ,buffer) `(:position ,position)))
331 (t
332 (etypecase location
333 (pathname
334 (make-location `(:file ,(filename location))
335 `(:function-name ,(function-name dspec))))
336 ((member :listener)
337 `(:error ,(format nil "Function defined in listener: ~S" dspec)))
338 ((member :unknown)
339 `(:error ,(format nil "Function location unkown: ~S" dspec))))
340 ))))
cc43d38 First version.
Helmut Eller authored
341
342 (defun signal-error-data-base (database &optional tmpfile buffer position)
343 (map-error-database
344 database
345 (lambda (filename dspec condition)
346 (signal-compiler-condition
347 (format nil "~A" condition)
348 (make-dspec-location dspec filename tmpfile buffer position)
349 condition))))
350
351 (defun signal-undefined-functions (htab filename
352 &optional tmpfile buffer position)
353 (maphash (lambda (unfun dspecs)
354 (dolist (dspec dspecs)
355 (signal-compiler-condition
356 (format nil "Undefined function ~A" unfun)
357 (make-dspec-location dspec filename tmpfile buffer position)
358 nil)))
359 htab))
3992f62 (make-dspec-location): Handle logical pathnames.
Helmut Eller authored
360
cc43d38 First version.
Helmut Eller authored
361 (defmethod compile-string-for-emacs (string &key buffer position)
362 (assert buffer)
363 (assert position)
364 (let ((*package* *buffer-package*)
365 (compiler::*error-database* '())
366 (tmpname (hcl:make-temp-file nil "lisp")))
367 (with-compilation-unit ()
368 (compile-from-temp-file string tmpname)
3992f62 (make-dspec-location): Handle logical pathnames.
Helmut Eller authored
369 (format t "~A~%" compiler:*messages*)
cc43d38 First version.
Helmut Eller authored
370 (signal-error-data-base
371 compiler::*error-database* tmpname buffer position)
372 (signal-undefined-functions compiler::*unknown-functions*
3992f62 (make-dspec-location): Handle logical pathnames.
Helmut Eller authored
373 tmpname tmpname buffer position))))
cc43d38 First version.
Helmut Eller authored
374
97a6e80 Xref support.
Helmut Eller authored
375 ;;; xref
376
ed76e57 Use the new format for source locations. Implement the
Helmut Eller authored
377 (defun lookup-xrefs (finder name)
378 (xref-results-for-emacs (funcall finder (from-string name))))
379
97a6e80 Xref support.
Helmut Eller authored
380 (defslimefun who-calls (function-name)
ed76e57 Use the new format for source locations. Implement the
Helmut Eller authored
381 (lookup-xrefs #'hcl:who-calls function-name))
97a6e80 Xref support.
Helmut Eller authored
382
383 (defslimefun who-references (variable)
ed76e57 Use the new format for source locations. Implement the
Helmut Eller authored
384 (lookup-xrefs #'hcl:who-references variable))
97a6e80 Xref support.
Helmut Eller authored
385
386 (defslimefun who-binds (variable)
ed76e57 Use the new format for source locations. Implement the
Helmut Eller authored
387 (lookup-xrefs #'hcl:who-binds variable))
97a6e80 Xref support.
Helmut Eller authored
388
389 (defslimefun who-sets (variable)
ed76e57 Use the new format for source locations. Implement the
Helmut Eller authored
390 (lookup-xrefs #'hcl:who-sets variable))
97a6e80 Xref support.
Helmut Eller authored
391
392 (defun xref-results-for-emacs (dspecs)
393 (let ((xrefs '()))
394 (dolist (dspec dspecs)
395 (loop for (dspec location) in (dspec:find-dspec-locations dspec)
396 do (push (cons (to-string dspec)
397 (make-dspec-location dspec location))
398 xrefs)))
399 (group-xrefs xrefs)))
400
ed76e57 Use the new format for source locations. Implement the
Helmut Eller authored
401 (defslimefun list-callers (symbol-name)
402 (lookup-xrefs #'hcl:who-calls symbol-name))
403
404 (defslimefun list-callees (symbol-name)
405 (lookup-xrefs #'hcl:calls-who symbol-name))
406
97a6e80 Xref support.
Helmut Eller authored
407 ;; (dspec:at-location
408 ;; ('(:inside (:buffer "foo" 34)))
409 ;; (defun foofun () (foofun)))
410
411 ;; (dspec:find-dspec-locations 'xref-results-for-emacs)
412 ;; (who-binds '*package*)
Something went wrong with that request. Please try again.