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

Contents of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.33 - (show annotations)
Wed Mar 10 08:24:45 2004 UTC (10 years, 1 month ago) by heller
Branch: MAIN
Changes since 1.32: +16 -27 lines
(find-definitions): Some tweaking.
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
11 (in-package :swank-backend)
12
13 (eval-when (:compile-toplevel :load-toplevel :execute)
14 (require "comm"))
15
16 (import
17 '(stream:fundamental-character-output-stream
18 stream:stream-write-char
19 stream:stream-force-output
20 stream:fundamental-character-input-stream
21 stream:stream-read-char
22 stream:stream-listen
23 stream:stream-unread-char
24 stream:stream-clear-input
25 stream:stream-line-column
26 ))
27
28 ;;; TCP server
29
30 (defimplementation preferred-communication-style ()
31 :spawn)
32
33 (defun socket-fd (socket)
34 (etypecase socket
35 (fixnum socket)
36 (comm:socket-stream (comm:socket-stream-socket socket))))
37
38 (defimplementation create-socket (host port)
39 (multiple-value-bind (socket where errno)
40 (comm::create-tcp-socket-for-service port :address host)
41 (cond (socket socket)
42 (t (error 'network-error
43 :format-control "~A failed: ~A (~D)"
44 :format-arguments (list where
45 (list #+unix (lw:get-unix-error errno))
46 errno))))))
47
48 (defimplementation local-port (socket)
49 (nth-value 1 (comm:get-socket-address (socket-fd socket))))
50
51 (defimplementation close-socket (socket)
52 (comm::close-socket (socket-fd socket)))
53
54 (defimplementation accept-connection (socket)
55 (let ((fd (comm::get-fd-from-socket socket)))
56 (assert (/= fd -1))
57 (make-instance 'comm:socket-stream :socket fd :direction :io
58 :element-type 'base-char)))
59
60 (defimplementation emacs-connected ()
61 ;; Set SIGINT handler on Swank request handler thread.
62 #-win32
63 (sys:set-signal-handler +sigint+ (make-sigint-handler mp:*current-process*)))
64
65 ;;; Unix signals
66
67 (defun sigint-handler ()
68 (with-simple-restart (continue "Continue from SIGINT handler.")
69 (invoke-debugger "SIGINT")))
70
71 (defun make-sigint-handler (process)
72 (lambda (&rest args)
73 (declare (ignore args))
74 (mp:process-interrupt process #'sigint-handler)))
75
76 (defmethod call-without-interrupts (fn)
77 (lispworks:without-interrupts (funcall fn)))
78
79 (defimplementation getpid ()
80 #+win32 (win32:get-current-process-id)
81 #-win32 (system::getpid))
82
83 (defimplementation lisp-implementation-type-name ()
84 "lispworks")
85
86 (defimplementation arglist (symbol)
87 (let ((arglist (lw:function-lambda-list symbol)))
88 (etypecase arglist
89 ((member :dont-know)
90 (error "<arglist-unavailable>"))
91 (list arglist))))
92
93 (defimplementation macroexpand-all (form)
94 (walker:walk-form form))
95
96 (defimplementation describe-symbol-for-emacs (symbol)
97 "Return a plist describing SYMBOL.
98 Return NIL if the symbol is unbound."
99 (let ((result '()))
100 (labels ((first-line (string)
101 (let ((pos (position #\newline string)))
102 (if (null pos) string (subseq string 0 pos))))
103 (doc (kind &optional (sym symbol))
104 (let ((string (documentation sym kind)))
105 (if string
106 (first-line string)
107 :not-documented)))
108 (maybe-push (property value)
109 (when value
110 (setf result (list* property value result)))))
111 (maybe-push
112 :variable (when (boundp symbol)
113 (doc 'variable)))
114 (maybe-push
115 :function (if (fboundp symbol)
116 (doc 'function)))
117 (maybe-push
118 :class (if (find-class symbol nil)
119 (doc 'class)))
120 result)))
121
122 (defimplementation describe-definition (symbol type)
123 (ecase type
124 (:variable (describe-symbol symbol))
125 (:class (describe (find-class symbol)))
126 (:function (describe-function symbol))))
127
128 (defun describe-function (symbol)
129 (cond ((fboundp symbol)
130 (format t "~%(~A~{ ~A~})~%~%~:[(not documented)~;~:*~A~]~%"
131 (string-downcase symbol)
132 (mapcar #'string-upcase
133 (lispworks:function-lambda-list symbol))
134 (documentation symbol 'function))
135 (describe (symbol-function symbol)))
136 (t (format t "~S is not fbound" symbol))))
137
138 (defun describe-symbol (sym)
139 (format t "~A is a symbol in package ~A." sym (symbol-package sym))
140 (when (boundp sym)
141 (format t "~%~%Value: ~A" (symbol-value sym)))
142 (let ((doc (documentation sym 'variable)))
143 (when doc
144 (format t "~%~%Variable documentation:~%~A" doc)))
145 (when (fboundp sym)
146 (describe-function sym)))
147
148 ;;; Debugging
149
150 (defvar *sldb-top-frame*)
151
152 (defimplementation call-with-debugging-environment (fn)
153 (dbg::with-debugger-stack ()
154 (let ((*sldb-top-frame* (dbg::debugger-stack-current-frame
155 dbg::*debugger-stack*)))
156 (funcall fn))))
157
158 (defun interesting-frame-p (frame)
159 (or (dbg::call-frame-p frame)
160 (dbg::derived-call-frame-p frame)
161 (dbg::foreign-frame-p frame)
162 (dbg::interpreted-call-frame-p frame)
163 ;;(dbg::catch-frame-p frame)
164 ))
165
166 (defun nth-frame (index)
167 (do ((frame *sldb-top-frame* (dbg::frame-next frame))
168 (i index (if (interesting-frame-p frame) (1- i) i)))
169 ((and (interesting-frame-p frame) (zerop i)) frame)
170 (assert frame)))
171
172 (defimplementation compute-backtrace (start end)
173 (let ((end (or end most-positive-fixnum))
174 (backtrace '()))
175 (do ((frame (nth-frame start) (dbg::frame-next frame))
176 (i start))
177 ((or (not frame) (= i end)) (nreverse backtrace))
178 (when (interesting-frame-p frame)
179 (incf i)
180 (push frame backtrace)))))
181
182 (defimplementation print-frame (frame stream)
183 (cond ((dbg::call-frame-p frame)
184 (format stream "~A ~A"
185 (dbg::call-frame-function-name frame)
186 (dbg::call-frame-arglist frame)))
187 (t (princ frame stream))))
188
189 (defimplementation frame-locals (n)
190 (let ((frame (nth-frame n)))
191 (if (dbg::call-frame-p frame)
192 (destructuring-bind (vars with)
193 (dbg::frame-locals-format-list frame #'list 75 0)
194 (declare (ignore with))
195 (mapcar (lambda (var)
196 (destructuring-bind (name value symbol location) var
197 (declare (ignore name location))
198 (list :name symbol :id 0
199 :value value)))
200 vars)))))
201
202 (defimplementation frame-catch-tags (index)
203 (declare (ignore index))
204 nil)
205
206 (defimplementation frame-source-location-for-emacs (frame)
207 (let ((frame (nth-frame frame)))
208 (if (dbg::call-frame-p frame)
209 (let ((name (dbg::call-frame-function-name frame)))
210 (if name
211 (function-name-location name))))))
212
213 (defimplementation eval-in-frame (form frame-number)
214 (let ((frame (nth-frame frame-number)))
215 (dbg::dbg-eval form frame)))
216
217 (defimplementation return-from-frame (frame-number form)
218 (let* ((frame (nth-frame frame-number))
219 (return-frame (dbg::find-frame-for-return frame)))
220 (dbg::dbg-return-from-call-frame frame form return-frame
221 dbg::*debugger-stack*)))
222
223 (defimplementation restart-frame (frame-number)
224 (let ((frame (nth-frame frame-number)))
225 (dbg::restart-frame frame :same-args t)))
226
227 ;;; Definition finding
228
229 (defun function-name-location (name)
230 (let ((defs (find-definitions name)))
231 (cond (defs (cadr (first defs)))
232 (t (list :error (format nil "Source location not available for: ~S"
233 name))))))
234
235 (defimplementation find-definitions (name)
236 (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name)))
237 (loop for (dspec location) in locations
238 collect (list dspec (make-dspec-location dspec location)))))
239
240 ;;; Compilation
241
242 (defimplementation swank-compile-file (filename load-p)
243 (let ((compiler::*error-database* '()))
244 (with-compilation-unit ()
245 (compile-file filename :load load-p)
246 (signal-error-data-base compiler::*error-database* filename)
247 (signal-undefined-functions compiler::*unknown-functions* filename))))
248
249 (defun map-error-database (database fn)
250 (loop for (filename . defs) in database do
251 (loop for (dspec . conditions) in defs do
252 (dolist (c conditions)
253 (funcall fn filename dspec c)))))
254
255 (defun lispworks-severity (condition)
256 (cond ((not condition) :warning)
257 (t (etypecase condition
258 (error :error)
259 (style-warning :warning)
260 (warning :warning)))))
261
262 (defun signal-compiler-condition (message location condition)
263 (check-type message string)
264 (signal
265 (make-instance 'compiler-condition :message message
266 :severity (lispworks-severity condition)
267 :location location
268 :original-condition condition)))
269
270 (defun compile-from-temp-file (string filename)
271 (unwind-protect
272 (progn
273 (with-open-file (s filename :direction :output :if-exists :supersede)
274 (write-string string s)
275 (finish-output s))
276 (let ((binary-filename (compile-file filename :load t)))
277 (when binary-filename
278 (delete-file binary-filename))))
279 (delete-file filename)))
280
281 (defun dspec-buffer-position (dspec)
282 (list :function-name (string (dspec:dspec-primary-name dspec))))
283
284 (defun emacs-buffer-location-p (location)
285 (and (consp location)
286 (eq (car location) :emacs-buffer)))
287
288 (defun make-dspec-location (dspec location)
289 (flet ((filename (pathname)
290 (multiple-value-bind (truename condition)
291 (ignore-errors (truename pathname))
292 (cond (condition
293 (return-from make-dspec-location
294 (list :error (format nil "~A" condition))))
295 (t (namestring truename)))))
296 (function-name (dspec)
297 (etypecase dspec
298 (symbol (symbol-name dspec))
299 (cons (string (dspec:dspec-primary-name dspec))))))
300 (etypecase location
301 ((or pathname string)
302 (make-location `(:file ,(filename location))
303 (dspec-buffer-position dspec)))
304 (symbol `(:error ,(format nil "Cannot resolve location: ~S" location)))
305 ((satisfies emacs-buffer-location-p)
306 (destructuring-bind (_ buffer offset string) location
307 (declare (ignore _ offset string))
308 (make-location `(:buffer ,buffer)
309 (dspec-buffer-position dspec)))))))
310
311 (defun signal-error-data-base (database location)
312 (map-error-database
313 database
314 (lambda (filename dspec condition)
315 (declare (ignore filename))
316 (signal-compiler-condition
317 (format nil "~A" condition)
318 (make-dspec-location dspec location)
319 condition))))
320
321 (defun signal-undefined-functions (htab filename)
322 (maphash (lambda (unfun dspecs)
323 (dolist (dspec dspecs)
324 (signal-compiler-condition
325 (format nil "Undefined function ~A" unfun)
326 (make-dspec-location dspec filename)
327 nil)))
328 htab))
329
330 (defimplementation swank-compile-string (string &key buffer position)
331 (assert buffer)
332 (assert position)
333 (let* ((location (list :emacs-buffer buffer position string))
334 (compiler::*error-database* '())
335 (tmpname (hcl:make-temp-file nil "lisp")))
336 (with-compilation-unit ()
337 (compile-from-temp-file
338 (with-standard-io-syntax
339 (format nil "~S~%~A" `(eval-when (:compile-toplevel)
340 (setq dspec::*location* (list ,@location)))
341 string))
342 tmpname)
343 (signal-error-data-base compiler::*error-database* location)
344 (signal-undefined-functions compiler::*unknown-functions* location))))
345
346 ;;; xref
347
348 (defmacro defxref (name function)
349 `(defimplementation ,name (name)
350 (xref-results (,function name))))
351
352 (defxref who-calls hcl:who-calls)
353 (defxref who-references hcl:who-references)
354 (defxref who-binds hcl:who-binds)
355 (defxref who-sets hcl:who-sets)
356 (defxref list-callees hcl:calls-who)
357
358 (defun xref-results (dspecs)
359 (loop for dspec in dspecs
360 nconc (loop for (dspec location) in
361 (dspec:dspec-definition-locations dspec)
362 collect (list dspec
363 (make-dspec-location dspec location)))))
364 ;;; Inspector
365
366 (defmethod inspected-parts (o)
367 (multiple-value-bind (names values _getter _setter type)
368 (lw:get-inspector-values o nil)
369 (declare (ignore _getter _setter))
370 (values (format nil "~A~% is a ~A" o type)
371 (mapcar (lambda (name value)
372 (cons (princ-to-string name) value))
373 names values))))
374
375 ;;; Multithreading
376
377 (defimplementation startup-multiprocessing ()
378 (mp:initialize-multiprocessing))
379
380 (defimplementation spawn (fn &key name)
381 (mp:process-run-function name () fn))
382
383 (defimplementation thread-name (thread)
384 (mp:process-name thread))
385
386 (defimplementation thread-status (thread)
387 (format nil "~A ~D"
388 (mp:process-whostate thread)
389 (mp:process-priority thread)))
390
391 (defimplementation make-lock (&key name)
392 (mp:make-lock :name name))
393
394 (defimplementation call-with-lock-held (lock function)
395 (mp:with-lock (lock) (funcall function)))
396
397 (defimplementation current-thread ()
398 mp:*current-process*)
399
400 (defimplementation all-threads ()
401 (mp:list-all-processes))
402
403 (defimplementation interrupt-thread (thread fn)
404 (mp:process-interrupt thread fn))
405
406 (defimplementation kill-thread (thread)
407 (mp:process-kill thread))
408
409 (defimplementation thread-alive-p (thread)
410 (mp:process-alive-p thread))
411
412 (defvar *mailbox-lock* (mp:make-lock))
413
414 (defun mailbox (thread)
415 (mp:with-lock (*mailbox-lock*)
416 (or (getf (mp:process-plist thread) 'mailbox)
417 (setf (getf (mp:process-plist thread) 'mailbox)
418 (mp:make-mailbox)))))
419
420 (defimplementation receive ()
421 (mp:mailbox-read (mailbox mp:*current-process*)))
422
423 (defimplementation send (thread object)
424 (mp:mailbox-send (mailbox thread) object))
425

  ViewVC Help
Powered by ViewVC 1.1.5