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

Contents of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (show annotations)
Mon Jan 19 20:14:35 2004 UTC (10 years, 2 months ago) by lgorrie
Branch: MAIN
Changes since 1.16: +34 -39 lines
Updated to use `defimplementation'.
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.17 2004/01/19 20:14:35 lgorrie 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 (defimplementation 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 (defimplementation local-port (socket)
48 (nth-value 1 (comm:get-socket-address (socket-fd socket))))
49
50 (defimplementation close-socket (socket)
51 (comm::close-socket (socket-fd socket)))
52
53 (defimplementation 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 (defimplementation spawn (fn &key name)
60 (mp:process-run-function name () fn))
61
62 (defimplementation 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 (with-simple-restart (continue "Continue from SIGINT handler.")
71 (invoke-debugger "SIGINT")))
72
73 (defmethod call-without-interrupts (fn)
74 (lispworks:without-interrupts (funcall fn)))
75
76 (defmethod getpid ()
77 (system::getpid))
78
79
80 (defimplementation arglist-string (fname)
81 (format-arglist fname #'lw:function-lambda-list))
82
83 (defimplementation macroexpand-all (form)
84 (walker:walk-form form))
85
86 (defimplementation 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 (defimplementation describe-definition (symbol-name type)
114 (case type
115 ;; FIXME: This should cover all types returned by
116 ;; DESCRIBE-SYMBOL-FOR-EMACS.
117 (:function (describe-function symbol-name))))
118
119 (defun describe-function (symbol-name)
120 (with-output-to-string (*standard-output*)
121 (let ((sym (from-string symbol-name)))
122 (cond ((fboundp sym)
123 (format t "~%(~A~{ ~A~})~%~%~:[(not documented)~;~:*~A~]~%"
124 (string-downcase sym)
125 (mapcar #'string-upcase
126 (lispworks:function-lambda-list sym))
127 (documentation sym 'function))
128 (describe (symbol-function sym)))
129 (t (format t "~S is not fbound" sym))))))
130
131 #+(or)
132 (defimplementation describe-object ((sym symbol) *standard-output*)
133 (format t "~A is a symbol in package ~A." sym (symbol-package sym))
134 (when (boundp sym)
135 (format t "~%~%Value: ~A" (symbol-value sym)))
136 (let ((doc (documentation sym 'variable)))
137 (when doc
138 (format t "~%~%Variable documentation:~%~A" doc)))
139 (when (fboundp sym)
140 (format t "~%~%(~A~{ ~A~})"
141 (string-downcase sym)
142 (mapcar #'string-upcase
143 (lispworks:function-lambda-list sym))))
144 (let ((doc (documentation sym 'function)))
145 (when doc (format t "~%~%~A~%" doc))))
146
147 ;;; Debugging
148
149 (defvar *sldb-restarts*)
150
151 (defslimefun sldb-abort ()
152 (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
153
154 (defimplementation call-with-debugging-environment (fn)
155 (dbg::with-debugger-stack ()
156 (let ((*sldb-restarts* (compute-restarts *swank-debugger-condition*)))
157 (funcall fn))))
158
159 (defun format-restarts-for-emacs ()
160 (loop for restart in *sldb-restarts*
161 collect (list (princ-to-string (restart-name restart))
162 (princ-to-string restart))))
163
164 (defun interesting-frame-p (frame)
165 (or (dbg::call-frame-p frame)
166 (dbg::catch-frame-p frame)))
167
168 (defun nth-frame (index)
169 (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*)
170 (dbg::frame-next frame))
171 (i index (if (interesting-frame-p frame) (1- i) i)))
172 ((and (interesting-frame-p frame) (zerop i)) frame)
173 (assert frame)))
174
175 (defun compute-backtrace (start end)
176 (let ((end (or end most-positive-fixnum))
177 (backtrace '()))
178 (do ((frame (nth-frame start) (dbg::frame-next frame))
179 (i start))
180 ((or (not frame) (= i end)) (nreverse backtrace))
181 (when (interesting-frame-p frame)
182 (incf i)
183 (push frame backtrace)))))
184
185 (defimplementation backtrace (start end)
186 (flet ((format-frame (f i)
187 (print-with-frame-label
188 i (lambda (s)
189 (cond ((dbg::call-frame-p f)
190 (format s "~A ~A"
191 (dbg::call-frame-function-name f)
192 (dbg::call-frame-arglist f)))
193 (t (princ f s)))))))
194 (loop for i from start
195 for f in (compute-backtrace start end)
196 collect (list i (format-frame f i)))))
197
198 (defimplementation debugger-info-for-emacs (start end)
199 (list (debugger-condition-for-emacs)
200 (format-restarts-for-emacs)
201 (backtrace start end)))
202
203 (defun nth-restart (index)
204 (nth index *sldb-restarts*))
205
206 (defslimefun invoke-nth-restart (index)
207 (invoke-restart-interactively (nth-restart index)))
208
209 (defimplementation frame-locals (n)
210 (let ((frame (nth-frame n)))
211 (if (dbg::call-frame-p frame)
212 (destructuring-bind (vars with)
213 (dbg::frame-locals-format-list frame #'list 75 0)
214 (declare (ignore with))
215 (loop for (name value symbol location) in vars
216 collect (list :name (to-string symbol) :id 0
217 :value-string (princ-to-string value)))))))
218
219 (defimplementation frame-catch-tags (index)
220 (declare (ignore index))
221 nil)
222
223 (defimplementation frame-source-location-for-emacs (frame)
224 (let ((frame (nth-frame frame)))
225 (if (dbg::call-frame-p frame)
226 (let ((func (dbg::call-frame-function-name frame)))
227 (if func
228 (dspec-source-location func))))))
229
230 (defun dspec-source-location (dspec)
231 (destructuring-bind (first) (dspec-source-locations dspec)
232 first))
233
234 (defun dspec-source-locations (dspec)
235 (let ((locations (dspec:find-dspec-locations dspec)))
236 (cond ((not locations)
237 (list :error (format nil "Cannot find source for ~S" dspec)))
238 (t
239 (loop for (dspec location) in locations
240 collect (make-dspec-location dspec location))))))
241
242 (defimplementation find-function-locations (fname)
243 (dspec-source-locations (from-string fname)))
244
245 (defimplementation compile-file-for-emacs (filename load-p)
246 (let ((compiler::*error-database* '()))
247 (with-compilation-unit ()
248 (compile-file filename :load load-p)
249 (signal-error-data-base compiler::*error-database*)
250 (signal-undefined-functions compiler::*unknown-functions* filename))))
251
252 (defun map-error-database (database fn)
253 (loop for (filename . defs) in database do
254 (loop for (dspec . conditions) in defs do
255 (dolist (c conditions)
256 (funcall fn filename dspec c)))))
257
258 (defun lispworks-severity (condition)
259 (cond ((not condition) :warning)
260 (t (etypecase condition
261 (error :error)
262 (style-warning :warning)
263 (warning :warning)))))
264
265 (defun signal-compiler-condition (message location condition)
266 (check-type message string)
267 (signal
268 (make-instance 'compiler-condition :message message
269 :severity (lispworks-severity condition)
270 :location location
271 :original-condition condition)))
272
273 (defun compile-from-temp-file (string filename)
274 (unwind-protect
275 (progn
276 (with-open-file (s filename :direction :output :if-exists :supersede)
277 (write-string string s)
278 (finish-output s))
279 (let ((binary-filename (compile-file filename :load t)))
280 (when binary-filename
281 (delete-file binary-filename))))
282 (delete-file filename)))
283
284 (defun make-dspec-location (dspec location &optional tmpfile buffer position)
285 (flet ((from-buffer-p ()
286 (and (pathnamep location) tmpfile
287 (pathname-match-p location tmpfile)))
288 (filename (pathname)
289 (multiple-value-bind (truename condition)
290 (ignore-errors (truename pathname))
291 (cond (condition
292 (return-from make-dspec-location
293 (list :error (format nil "~A" condition))))
294 (t (namestring truename)))))
295 (function-name (dspec)
296 (etypecase dspec
297 (symbol (symbol-name dspec))
298 (cons (symbol-name (dspec:dspec-primary-name dspec))))))
299 (cond ((from-buffer-p)
300 (make-location `(:buffer ,buffer) `(:position ,position)))
301 (t
302 (etypecase location
303 ((or pathname string)
304 (make-location `(:file ,(filename location))
305 `(:function-name ,(function-name dspec))))
306 ((member :listener)
307 `(:error ,(format nil "Function defined in listener: ~S" dspec)))
308 ((member :unknown)
309 `(:error ,(format nil "Function location unkown: ~S" dspec))))
310 ))))
311
312 (defun signal-error-data-base (database &optional tmpfile buffer position)
313 (map-error-database
314 database
315 (lambda (filename dspec condition)
316 (signal-compiler-condition
317 (format nil "~A" condition)
318 (make-dspec-location dspec filename tmpfile buffer position)
319 condition))))
320
321 (defun signal-undefined-functions (htab filename
322 &optional tmpfile buffer position)
323 (maphash (lambda (unfun dspecs)
324 (dolist (dspec dspecs)
325 (signal-compiler-condition
326 (format nil "Undefined function ~A" unfun)
327 (make-dspec-location dspec filename tmpfile buffer position)
328 nil)))
329 htab))
330
331 (defimplementation compile-string-for-emacs (string &key buffer position)
332 (assert buffer)
333 (assert position)
334 (let ((*package* *buffer-package*)
335 (compiler::*error-database* '())
336 (tmpname (hcl:make-temp-file nil "lisp")))
337 (with-compilation-unit ()
338 (compile-from-temp-file string tmpname)
339 (format t "~A~%" compiler:*messages*)
340 (signal-error-data-base
341 compiler::*error-database* tmpname buffer position)
342 (signal-undefined-functions compiler::*unknown-functions*
343 tmpname tmpname buffer position))))
344
345 ;;; xref
346
347 (defun lookup-xrefs (finder name)
348 (xref-results-for-emacs (funcall finder (from-string name))))
349
350 (defimplementation who-calls (function-name)
351 (lookup-xrefs #'hcl:who-calls function-name))
352
353 (defimplementation who-references (variable)
354 (lookup-xrefs #'hcl:who-references variable))
355
356 (defimplementation who-binds (variable)
357 (lookup-xrefs #'hcl:who-binds variable))
358
359 (defimplementation who-sets (variable)
360 (lookup-xrefs #'hcl:who-sets variable))
361
362 (defun xref-results-for-emacs (dspecs)
363 (let ((xrefs '()))
364 (dolist (dspec dspecs)
365 (loop for (dspec location) in (dspec:find-dspec-locations dspec)
366 do (push (cons (to-string dspec)
367 (make-dspec-location dspec location))
368 xrefs)))
369 (group-xrefs xrefs)))
370
371 (defimplementation list-callers (symbol-name)
372 (lookup-xrefs #'hcl:who-calls symbol-name))
373
374 (defimplementation list-callees (symbol-name)
375 (lookup-xrefs #'hcl:calls-who symbol-name))
376
377 ;;; Multithreading
378
379 (defmethod startup-multiprocessing ()
380 (mp:initialize-multiprocessing))
381
382 (defmethod spawn (fn &key name)
383 (mp:process-run-function name () fn))
384
385 ;; XXX: shurtcut
386 (defmethod thread-id ()
387 (mp:process-name mp:*current-process*))
388
389 (defmethod thread-name (thread-id)
390 thread-id)
391
392 (defmethod make-lock (&key name)
393 (mp:make-lock :name name))
394
395 (defmethod call-with-lock-held (lock function)
396 (mp:with-lock (lock) (funcall function)))
397

  ViewVC Help
Powered by ViewVC 1.1.5