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

Contents of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5