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

Contents of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.15 - (show annotations)
Sun Jan 18 07:15:49 2004 UTC (10 years, 3 months ago) by heller
Branch: MAIN
Changes since 1.14: +9 -21 lines
(arglist-string): Refactor common code to swank.lisp.

(call-without-interrupts, getpid): Are now generic functions.
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.15 2004/01/18 07:15:49 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 ;;; TCP server
31
32 (defun socket-fd (socket)
33 (etypecase socket
34 (fixnum socket)
35 (comm:socket-stream (comm:socket-stream-socket socket))))
36
37 (defmethod create-socket (port)
38 (multiple-value-bind (socket where errno)
39 (comm::create-tcp-socket-for-service port :address "localhost")
40 (cond (socket socket)
41 (t (error 'network-error
42 :format-control "~A failed: ~A (~D)"
43 :format-arguments (list where
44 (list #+unix (lw:get-unix-error errno))
45 errno))))))
46
47 (defmethod local-port (socket)
48 (nth-value 1 (comm:get-socket-address (socket-fd socket))))
49
50 (defmethod close-socket (socket)
51 (comm::close-socket (socket-fd socket)))
52
53 (defmethod accept-connection (socket)
54 (let ((fd (comm::get-fd-from-socket socket)))
55 (assert (/= fd -1))
56 (make-instance 'comm:socket-stream :socket fd :direction :io
57 :element-type 'base-char)))
58
59 (defmethod spawn (fn &key name)
60 (mp:process-run-function name () fn))
61
62 (defmethod emacs-connected ()
63 ;; Set SIGINT handler on Swank request handler thread.
64 (sys:set-signal-handler +sigint+ #'sigint-handler))
65
66 ;;; Unix signals
67
68 (defun sigint-handler (&rest args)
69 (declare (ignore args))
70 (invoke-debugger "SIGINT"))
71
72 (defmethod call-without-interrupts (fn)
73 (lispworks:without-interrupts (funcall fn)))
74
75 (defmethod getpid ()
76 (system::getpid))
77
78 ;;;
79
80 (defmethod arglist-string (fname)
81 (format-arglist fname #'lw:function-lambda-list))
82
83 (defmethod macroexpand-all (form)
84 (walker:walk-form form))
85
86 (defmethod describe-symbol-for-emacs (symbol)
87 "Return a plist describing SYMBOL.
88 Return NIL if the symbol is unbound."
89 (let ((result '()))
90 (labels ((first-line (string)
91 (let ((pos (position #\newline string)))
92 (if (null pos) string (subseq string 0 pos))))
93 (doc (kind &optional (sym symbol))
94 (let ((string (documentation sym kind)))
95 (if string
96 (first-line string)
97 :not-documented)))
98 (maybe-push (property value)
99 (when value
100 (setf result (list* property value result)))))
101 (maybe-push
102 :variable (when (boundp symbol)
103 (doc 'variable)))
104 (maybe-push
105 :function (if (fboundp symbol)
106 (doc 'function)))
107 (maybe-push
108 :class (if (find-class symbol nil)
109 (doc 'class)))
110 (if result
111 (list* :designator (to-string symbol) result)))))
112
113 (defslimefun describe-function (symbol-name)
114 (with-output-to-string (*standard-output*)
115 (let ((sym (from-string symbol-name)))
116 (cond ((fboundp sym)
117 (format t "~%(~A~{ ~A~})~%~%~:[(not documented)~;~:*~A~]~%"
118 (string-downcase sym)
119 (mapcar #'string-upcase
120 (lispworks:function-lambda-list sym))
121 (documentation sym 'function))
122 (describe (symbol-function sym)))
123 (t (format t "~S is not fbound" sym))))))
124
125 #+(or)
126 (defmethod describe-object ((sym symbol) *standard-output*)
127 (format t "~A is a symbol in package ~A." sym (symbol-package sym))
128 (when (boundp sym)
129 (format t "~%~%Value: ~A" (symbol-value sym)))
130 (let ((doc (documentation sym 'variable)))
131 (when doc
132 (format t "~%~%Variable documentation:~%~A" doc)))
133 (when (fboundp sym)
134 (format t "~%~%(~A~{ ~A~})"
135 (string-downcase sym)
136 (mapcar #'string-upcase
137 (lispworks:function-lambda-list sym))))
138 (let ((doc (documentation sym 'function)))
139 (when doc (format t "~%~%~A~%" doc))))
140
141 ;;; Debugging
142
143 (defvar *sldb-restarts*)
144
145 (defslimefun sldb-abort ()
146 (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
147
148 (defmethod call-with-debugging-environment (fn)
149 (dbg::with-debugger-stack ()
150 (let ((*sldb-restarts* (compute-restarts *swank-debugger-condition*)))
151 (funcall fn))))
152
153 (defun format-restarts-for-emacs ()
154 (loop for restart in *sldb-restarts*
155 collect (list (princ-to-string (restart-name restart))
156 (princ-to-string restart))))
157
158 (defun interesting-frame-p (frame)
159 (or (dbg::call-frame-p frame)
160 (dbg::catch-frame-p frame)))
161
162 (defun nth-frame (index)
163 (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*)
164 (dbg::frame-next frame))
165 (i index (if (interesting-frame-p frame) (1- i) i)))
166 ((and (interesting-frame-p frame) (zerop i)) frame)
167 (assert frame)))
168
169 (defun compute-backtrace (start end)
170 (let ((end (or end most-positive-fixnum))
171 (backtrace '()))
172 (do ((frame (nth-frame start) (dbg::frame-next frame))
173 (i start))
174 ((or (not frame) (= i end)) (nreverse backtrace))
175 (when (interesting-frame-p frame)
176 (incf i)
177 (push frame backtrace)))))
178
179 (defmethod backtrace (start end)
180 (flet ((format-frame (f i)
181 (print-with-frame-label
182 i (lambda (s)
183 (cond ((dbg::call-frame-p f)
184 (format s "~A ~A"
185 (dbg::call-frame-function-name f)
186 (dbg::call-frame-arglist f)))
187 (t (princ f s)))))))
188 (loop for i from start
189 for f in (compute-backtrace start end)
190 collect (list i (format-frame f i)))))
191
192 (defmethod debugger-info-for-emacs (start end)
193 (list (debugger-condition-for-emacs)
194 (format-restarts-for-emacs)
195 (backtrace start end)))
196
197 (defun nth-restart (index)
198 (nth index *sldb-restarts*))
199
200 (defslimefun invoke-nth-restart (index)
201 (invoke-restart-interactively (nth-restart index)))
202
203 (defmethod frame-locals (n)
204 (let ((frame (nth-frame n)))
205 (if (dbg::call-frame-p frame)
206 (destructuring-bind (vars with)
207 (dbg::frame-locals-format-list frame #'list 75 0)
208 (declare (ignore with))
209 (loop for (name value symbol location) in vars
210 collect (list :name (to-string symbol) :id 0
211 :value-string (princ-to-string value)))))))
212
213 (defmethod frame-catch-tags (index)
214 (declare (ignore index))
215 nil)
216
217 (defmethod frame-source-location-for-emacs (frame)
218 (let ((frame (nth-frame frame)))
219 (if (dbg::call-frame-p frame)
220 (let ((func (dbg::call-frame-function-name frame)))
221 (if func
222 (dspec-source-location func))))))
223
224 (defun dspec-source-location (dspec)
225 (destructuring-bind (first) (dspec-source-locations dspec)
226 first))
227
228 (defun dspec-source-locations (dspec)
229 (let ((locations (dspec:find-dspec-locations dspec)))
230 (cond ((not locations)
231 (list :error (format nil "Cannot find source for ~S" dspec)))
232 (t
233 (loop for (dspec location) in locations
234 collect (make-dspec-location dspec location))))))
235
236 (defmethod find-function-locations (fname)
237 (dspec-source-locations (from-string fname)))
238
239 ;;; callers
240
241 (defun stringify-function-name-list (list)
242 (let ((*print-pretty* nil)) (mapcar #'to-string list)))
243
244 (defslimefun list-callers (symbol-name)
245 (stringify-function-name-list (hcl:who-calls (from-string symbol-name))))
246
247 ;;; Compilation
248
249 (defmethod compile-file-for-emacs (filename load-p)
250 (let ((compiler::*error-database* '()))
251 (with-compilation-unit ()
252 (compile-file filename :load load-p)
253 (signal-error-data-base compiler::*error-database*)
254 (signal-undefined-functions compiler::*unknown-functions* filename))))
255
256 (defun map-error-database (database fn)
257 (loop for (filename . defs) in database do
258 (loop for (dspec . conditions) in defs do
259 (dolist (c conditions)
260 (funcall fn filename dspec c)))))
261
262 (defun lispworks-severity (condition)
263 (cond ((not condition) :warning)
264 (t (etypecase condition
265 (error :error)
266 (style-warning :warning)
267 (warning :warning)))))
268
269 (defun signal-compiler-condition (message location condition)
270 (check-type message string)
271 (signal
272 (make-instance 'compiler-condition :message message
273 :severity (lispworks-severity condition)
274 :location location
275 :original-condition condition)))
276
277 (defun compile-from-temp-file (string filename)
278 (unwind-protect
279 (progn
280 (with-open-file (s filename :direction :output :if-exists :supersede)
281 (write-string string s)
282 (finish-output s))
283 (let ((binary-filename (compile-file filename :load t)))
284 (when binary-filename
285 (delete-file binary-filename))))
286 (delete-file filename)))
287
288 (defun make-dspec-location (dspec location &optional tmpfile buffer position)
289 (flet ((from-buffer-p ()
290 (and (pathnamep location) tmpfile
291 (pathname-match-p location tmpfile)))
292 (filename (pathname)
293 (multiple-value-bind (truename condition)
294 (ignore-errors (truename pathname))
295 (cond (condition
296 (return-from make-dspec-location
297 (list :error (format nil "~A" condition))))
298 (t (namestring truename)))))
299 (function-name (dspec)
300 (etypecase dspec
301 (symbol (symbol-name dspec))
302 (cons (symbol-name (dspec:dspec-primary-name dspec))))))
303 (cond ((from-buffer-p)
304 (make-location `(:buffer ,buffer) `(:position ,position)))
305 (t
306 (etypecase location
307 (pathname
308 (make-location `(:file ,(filename location))
309 `(:function-name ,(function-name dspec))))
310 ((member :listener)
311 `(:error ,(format nil "Function defined in listener: ~S" dspec)))
312 ((member :unknown)
313 `(:error ,(format nil "Function location unkown: ~S" dspec))))
314 ))))
315
316 (defun signal-error-data-base (database &optional tmpfile buffer position)
317 (map-error-database
318 database
319 (lambda (filename dspec condition)
320 (signal-compiler-condition
321 (format nil "~A" condition)
322 (make-dspec-location dspec filename tmpfile buffer position)
323 condition))))
324
325 (defun signal-undefined-functions (htab filename
326 &optional tmpfile buffer position)
327 (maphash (lambda (unfun dspecs)
328 (dolist (dspec dspecs)
329 (signal-compiler-condition
330 (format nil "Undefined function ~A" unfun)
331 (make-dspec-location dspec filename tmpfile buffer position)
332 nil)))
333 htab))
334
335 (defmethod compile-string-for-emacs (string &key buffer position)
336 (assert buffer)
337 (assert position)
338 (let ((*package* *buffer-package*)
339 (compiler::*error-database* '())
340 (tmpname (hcl:make-temp-file nil "lisp")))
341 (with-compilation-unit ()
342 (compile-from-temp-file string tmpname)
343 (format t "~A~%" compiler:*messages*)
344 (signal-error-data-base
345 compiler::*error-database* tmpname buffer position)
346 (signal-undefined-functions compiler::*unknown-functions*
347 tmpname tmpname buffer position))))
348
349 ;;; xref
350
351 (defun lookup-xrefs (finder name)
352 (xref-results-for-emacs (funcall finder (from-string name))))
353
354 (defslimefun who-calls (function-name)
355 (lookup-xrefs #'hcl:who-calls function-name))
356
357 (defslimefun who-references (variable)
358 (lookup-xrefs #'hcl:who-references variable))
359
360 (defslimefun who-binds (variable)
361 (lookup-xrefs #'hcl:who-binds variable))
362
363 (defslimefun who-sets (variable)
364 (lookup-xrefs #'hcl:who-sets variable))
365
366 (defun xref-results-for-emacs (dspecs)
367 (let ((xrefs '()))
368 (dolist (dspec dspecs)
369 (loop for (dspec location) in (dspec:find-dspec-locations dspec)
370 do (push (cons (to-string dspec)
371 (make-dspec-location dspec location))
372 xrefs)))
373 (group-xrefs xrefs)))
374
375 (defslimefun list-callers (symbol-name)
376 (lookup-xrefs #'hcl:who-calls symbol-name))
377
378 (defslimefun list-callees (symbol-name)
379 (lookup-xrefs #'hcl:calls-who symbol-name))
380
381 ;; (dspec:at-location
382 ;; ('(:inside (:buffer "foo" 34)))
383 ;; (defun foofun () (foofun)))
384
385 ;; (dspec:find-dspec-locations 'xref-results-for-emacs)
386 ;; (who-binds '*package*)

  ViewVC Help
Powered by ViewVC 1.1.5