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

Contents of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.30 - (show annotations)
Tue Mar 9 12:46:27 2004 UTC (10 years, 1 month ago) by heller
Branch: MAIN
Changes since 1.29: +64 -108 lines
Merge package-split branch into main trunk.
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::catch-frame-p frame)
161 ))
162
163 (defun nth-frame (index)
164 (do ((frame *sldb-top-frame* (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 (defimplementation 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 (defimplementation print-frame (frame stream)
180 (cond ((dbg::call-frame-p frame)
181 (format stream "~A ~A"
182 (dbg::call-frame-function-name frame)
183 (dbg::call-frame-arglist frame)))
184 (t (princ frame stream))))
185
186 (defimplementation frame-locals (n)
187 (let ((frame (nth-frame n)))
188 (if (dbg::call-frame-p frame)
189 (destructuring-bind (vars with)
190 (dbg::frame-locals-format-list frame #'list 75 0)
191 (declare (ignore with))
192 (mapcar (lambda (var)
193 (destructuring-bind (name value symbol location) var
194 (declare (ignore name location))
195 (list :name symbol :id 0
196 :value value)))
197 vars)))))
198
199 (defimplementation frame-catch-tags (index)
200 (declare (ignore index))
201 nil)
202
203 (defimplementation frame-source-location-for-emacs (frame)
204 (let ((frame (nth-frame frame)))
205 (if (dbg::call-frame-p frame)
206 (let ((func (dbg::call-frame-function-name frame)))
207 (if func
208 (cadr (name-source-location func)))))))
209
210 (defimplementation eval-in-frame (form frame-number)
211 (let ((frame (nth-frame frame-number)))
212 (dbg::dbg-eval form frame)))
213
214 (defimplementation return-from-frame (frame-number form)
215 (let* ((frame (nth-frame frame-number))
216 (return-frame (dbg::find-frame-for-return frame)))
217 (dbg::dbg-return-from-call-frame frame form return-frame
218 dbg::*debugger-stack*)))
219
220 (defimplementation restart-frame (frame-number)
221 (let ((frame (nth-frame frame-number)))
222 (dbg::restart-frame frame :same-args t)))
223
224 ;;; Definition finding
225
226 (defun name-source-location (name)
227 (first (name-source-locations name)))
228
229 (defun name-source-locations (name)
230 (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name)))
231 (cond ((not locations)
232 (list :error (format nil "Cannot find source for ~S" name)))
233 (t
234 (loop for (dspec location) in locations
235 collect (list dspec (make-dspec-location dspec location)))))))
236
237 (defimplementation find-definitions (name)
238 (name-source-locations name))
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 ;; XXX handle all cases in dspec:*dspec-classes*
282 (defun dspec-buffer-position (dspec)
283 (etypecase dspec
284 (cons (ecase (car dspec)
285 ((defun defmacro defgeneric defvar defstruct
286 method structure package)
287 `(:function-name ,(symbol-name (cadr dspec))))
288 ;; XXX this isn't quite right
289 (lw:top-level-form `(:source-path ,(cdr dspec) nil))))
290 (symbol `(:function-name ,(symbol-name dspec)))))
291
292 (defun emacs-buffer-location-p (location)
293 (and (consp location)
294 (eq (car location) :emacs-buffer)))
295
296 (defun make-dspec-location (dspec location)
297 (flet ((filename (pathname)
298 (multiple-value-bind (truename condition)
299 (ignore-errors (truename pathname))
300 (cond (condition
301 (return-from make-dspec-location
302 (list :error (format nil "~A" condition))))
303 (t (namestring truename)))))
304 (function-name (dspec)
305 (etypecase dspec
306 (symbol (symbol-name dspec))
307 (cons (string (dspec:dspec-primary-name dspec))))))
308 (etypecase location
309 ((or pathname string)
310 (make-location `(:file ,(filename location))
311 (dspec-buffer-position dspec)))
312 ((member :listener)
313 `(:error ,(format nil "Function defined in listener: ~S" dspec)))
314 ((member :unknown)
315 `(:error ,(format nil "Function location unkown: ~S" dspec)))
316 ((satisfies emacs-buffer-location-p)
317 (destructuring-bind (_ buffer offset string) location
318 (declare (ignore _ offset string))
319 (make-location `(:buffer ,buffer)
320 (dspec-buffer-position dspec)))))))
321
322 (defun signal-error-data-base (database location)
323 (map-error-database
324 database
325 (lambda (filename dspec condition)
326 (declare (ignore filename))
327 (signal-compiler-condition
328 (format nil "~A" condition)
329 (make-dspec-location dspec location)
330 condition))))
331
332 (defun signal-undefined-functions (htab filename)
333 (maphash (lambda (unfun dspecs)
334 (dolist (dspec dspecs)
335 (signal-compiler-condition
336 (format nil "Undefined function ~A" unfun)
337 (make-dspec-location dspec filename)
338 nil)))
339 htab))
340
341 (defimplementation swank-compile-string (string &key buffer position)
342 (assert buffer)
343 (assert position)
344 (let* ((location (list :emacs-buffer buffer position string))
345 (compiler::*error-database* '())
346 (tmpname (hcl:make-temp-file nil "lisp")))
347 (with-compilation-unit ()
348 (compile-from-temp-file
349 (with-standard-io-syntax
350 (format nil "~S~%~A" `(eval-when (:compile-toplevel)
351 (setq dspec::*location* (list ,@location)))
352 string))
353 tmpname)
354 (signal-error-data-base compiler::*error-database* location)
355 (signal-undefined-functions compiler::*unknown-functions* location))))
356
357 ;;; xref
358
359 (defun xrefs (dspecs)
360 (loop for dspec in dspecs
361 nconc (loop for (dspec location) in
362 (dspec:dspec-definition-locations dspec)
363 collect (list dspec
364 (make-dspec-location dspec location)))))
365
366 (defimplementation who-calls (name)
367 (xrefs (hcl:who-calls name)))
368
369 (defimplementation who-references (name)
370 (xrefs (hcl:who-references name)))
371
372 (defimplementation who-binds (name)
373 (xrefs (hcl:who-binds name)))
374
375 (defimplementation who-sets (name)
376 (xrefs (hcl:who-sets name)))
377
378 (defimplementation list-callers (name)
379 (xrefs (hcl:who-calls name)))
380
381 (defimplementation list-callees (name)
382 (xrefs (hcl:calls-who name)))
383
384 ;;; Inspector
385
386 (defmethod inspected-parts (o)
387 (multiple-value-bind (names values _getter _setter type)
388 (lw:get-inspector-values o nil)
389 (declare (ignore _getter _setter))
390 (values (format nil "~A~% is a ~A" o type)
391 (mapcar (lambda (name value)
392 (cons (princ-to-string name) value))
393 names values))))
394
395 ;;; Multithreading
396
397 (defimplementation startup-multiprocessing ()
398 (mp:initialize-multiprocessing))
399
400 (defimplementation spawn (fn &key name)
401 (mp:process-run-function name () fn))
402
403 (defimplementation thread-name (thread)
404 (mp:process-name thread))
405
406 (defimplementation thread-status (thread)
407 (format nil "~A ~D"
408 (mp:process-whostate thread)
409 (mp:process-priority thread)))
410
411 (defimplementation make-lock (&key name)
412 (mp:make-lock :name name))
413
414 (defimplementation call-with-lock-held (lock function)
415 (mp:with-lock (lock) (funcall function)))
416
417 (defimplementation current-thread ()
418 mp:*current-process*)
419
420 (defimplementation all-threads ()
421 (mp:list-all-processes))
422
423 (defimplementation interrupt-thread (thread fn)
424 (mp:process-interrupt thread fn))
425
426 (defimplementation kill-thread (thread)
427 (mp:process-kill thread))
428
429 (defimplementation thread-alive-p (thread)
430 (mp:process-alive-p thread))
431
432 (defvar *mailbox-lock* (mp:make-lock))
433
434 (defun mailbox (thread)
435 (mp:with-lock (*mailbox-lock*)
436 (or (getf (mp:process-plist thread) 'mailbox)
437 (setf (getf (mp:process-plist thread) 'mailbox)
438 (mp:make-mailbox)))))
439
440 (defimplementation receive ()
441 (mp:mailbox-read (mailbox mp:*current-process*)))
442
443 (defimplementation send (thread object)
444 (mp:mailbox-send (mailbox thread) object))
445

  ViewVC Help
Powered by ViewVC 1.1.5