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

Contents of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.29 - (show annotations)
Fri Mar 5 22:53:34 2004 UTC (10 years, 1 month ago) by heller
Branch: MAIN
CVS Tags: SLIME-0-11
Branch point for: package-split
Changes since 1.28: +5 -6 lines
(getpid, emacs-connected): Conditionalize for Windows.  Patch from Bill
Clementson.
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)
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 (setq *swank-in-background* :spawn)
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 (host port)
38 (multiple-value-bind (socket where errno)
39 (comm::create-tcp-socket-for-service port :address host)
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 emacs-connected ()
60 ;; Set SIGINT handler on Swank request handler thread.
61 #-win32
62 (sys:set-signal-handler +sigint+ (make-sigint-handler mp:*current-process*)))
63
64 ;;; Unix signals
65
66 (defun sigint-handler ()
67 (with-simple-restart (continue "Continue from SIGINT handler.")
68 (invoke-debugger "SIGINT")))
69
70 (defun make-sigint-handler (process)
71 (lambda (&rest args)
72 (declare (ignore args))
73 (mp:process-interrupt process #'sigint-handler)))
74
75 (defmethod call-without-interrupts (fn)
76 (lispworks:without-interrupts (funcall fn)))
77
78 (defimplementation getpid ()
79 #+win32 (win32:get-current-process-id)
80 #-win32 (system::getpid))
81
82 (defimplementation lisp-implementation-type-name ()
83 "lispworks")
84
85 (defimplementation arglist-string (fname)
86 (format-arglist fname
87 (lambda (symbol)
88 (let ((arglist (lw:function-lambda-list symbol)))
89 (etypecase arglist
90 ((member :dont-know)
91 (error "<arglist-unavailable>"))
92 (cons arglist))))))
93
94 (defimplementation macroexpand-all (form)
95 (walker:walk-form form))
96
97 (defimplementation describe-symbol-for-emacs (symbol)
98 "Return a plist describing SYMBOL.
99 Return NIL if the symbol is unbound."
100 (let ((result '()))
101 (labels ((first-line (string)
102 (let ((pos (position #\newline string)))
103 (if (null pos) string (subseq string 0 pos))))
104 (doc (kind &optional (sym symbol))
105 (let ((string (documentation sym kind)))
106 (if string
107 (first-line string)
108 :not-documented)))
109 (maybe-push (property value)
110 (when value
111 (setf result (list* property value result)))))
112 (maybe-push
113 :variable (when (boundp symbol)
114 (doc 'variable)))
115 (maybe-push
116 :function (if (fboundp symbol)
117 (doc 'function)))
118 (maybe-push
119 :class (if (find-class symbol nil)
120 (doc 'class)))
121 (if result
122 (list* :designator (to-string symbol) result)))))
123
124 (defimplementation describe-definition (symbol-name type)
125 (case type
126 ;; FIXME: This should cover all types returned by
127 ;; DESCRIBE-SYMBOL-FOR-EMACS.
128 (:function (describe-function symbol-name))))
129
130 (defun describe-function (symbol-name)
131 (with-output-to-string (*standard-output*)
132 (let ((sym (from-string symbol-name)))
133 (cond ((fboundp sym)
134 (format t "~%(~A~{ ~A~})~%~%~:[(not documented)~;~:*~A~]~%"
135 (string-downcase sym)
136 (mapcar #'string-upcase
137 (lispworks:function-lambda-list sym))
138 (documentation sym 'function))
139 (describe (symbol-function sym)))
140 (t (format t "~S is not fbound" sym))))))
141
142 #+(or)
143 (defimplementation describe-object ((sym symbol) *standard-output*)
144 (format t "~A is a symbol in package ~A." sym (symbol-package sym))
145 (when (boundp sym)
146 (format t "~%~%Value: ~A" (symbol-value sym)))
147 (let ((doc (documentation sym 'variable)))
148 (when doc
149 (format t "~%~%Variable documentation:~%~A" doc)))
150 (when (fboundp sym)
151 (format t "~%~%(~A~{ ~A~})"
152 (string-downcase sym)
153 (mapcar #'string-upcase
154 (lispworks:function-lambda-list sym))))
155 (let ((doc (documentation sym 'function)))
156 (when doc (format t "~%~%~A~%" doc))))
157
158 ;;; Debugging
159
160 (defvar *sldb-restarts*)
161 (defvar *sldb-top-frame*)
162
163 (defslimefun sldb-abort ()
164 (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
165
166 (defimplementation call-with-debugging-environment (fn)
167 (dbg::with-debugger-stack ()
168 (let ((*sldb-restarts* (compute-restarts *swank-debugger-condition*))
169 (*sldb-top-frame* (dbg::debugger-stack-current-frame
170 dbg::*debugger-stack*)))
171 (funcall fn))))
172
173 (defun format-restarts-for-emacs ()
174 (loop for restart in *sldb-restarts*
175 collect (list (princ-to-string (restart-name restart))
176 (princ-to-string restart))))
177
178 (defun interesting-frame-p (frame)
179 (or (dbg::call-frame-p frame)
180 ;;(dbg::catch-frame-p frame)
181 ))
182
183 (defun nth-frame (index)
184 (do ((frame *sldb-top-frame* (dbg::frame-next frame))
185 (i index (if (interesting-frame-p frame) (1- i) i)))
186 ((and (interesting-frame-p frame) (zerop i)) frame)
187 (assert frame)))
188
189 (defun compute-backtrace (start end)
190 (let ((end (or end most-positive-fixnum))
191 (backtrace '()))
192 (do ((frame (nth-frame start) (dbg::frame-next frame))
193 (i start))
194 ((or (not frame) (= i end)) (nreverse backtrace))
195 (when (interesting-frame-p frame)
196 (incf i)
197 (push frame backtrace)))))
198
199 (defimplementation backtrace (start end)
200 (flet ((format-frame (f i)
201 (print-with-frame-label
202 i (lambda (s)
203 (cond ((dbg::call-frame-p f)
204 (format s "~A ~A"
205 (dbg::call-frame-function-name f)
206 (dbg::call-frame-arglist f)))
207 (t (princ f s)))))))
208 (loop for i from start
209 for f in (compute-backtrace start end)
210 collect (list i (format-frame f i)))))
211
212 (defimplementation debugger-info-for-emacs (start end)
213 (list (debugger-condition-for-emacs)
214 (format-restarts-for-emacs)
215 (backtrace start end)))
216
217 (defun nth-restart (index)
218 (nth index *sldb-restarts*))
219
220 (defslimefun invoke-nth-restart (index)
221 (invoke-restart-interactively (nth-restart index)))
222
223 (defimplementation frame-locals (n)
224 (let ((frame (nth-frame n)))
225 (if (dbg::call-frame-p frame)
226 (destructuring-bind (vars with)
227 (dbg::frame-locals-format-list frame #'list 75 0)
228 (declare (ignore with))
229 (mapcar (lambda (var)
230 (destructuring-bind (name value symbol location) var
231 (declare (ignore name location))
232 (list :name symbol :id 0
233 :value value)))
234 vars)))))
235
236 (defimplementation frame-catch-tags (index)
237 (declare (ignore index))
238 nil)
239
240 (defimplementation frame-source-location-for-emacs (frame)
241 (let ((frame (nth-frame frame)))
242 (if (dbg::call-frame-p frame)
243 (let ((func (dbg::call-frame-function-name frame)))
244 (if func
245 (name-source-location func))))))
246
247 (defimplementation eval-in-frame (form frame-number)
248 (let ((frame (nth-frame frame-number)))
249 (dbg::dbg-eval form frame)))
250
251 (defimplementation return-from-frame (frame-number form)
252 (let* ((frame (nth-frame frame-number))
253 (return-frame (dbg::find-frame-for-return frame))
254 (form (from-string form)))
255 (dbg::dbg-return-from-call-frame frame form return-frame
256 dbg::*debugger-stack*)))
257
258 (defimplementation restart-frame (frame-number)
259 (let ((frame (nth-frame frame-number)))
260 (dbg::restart-frame frame :same-args t)))
261
262 ;;; Definition finding
263
264 (defun name-source-location (name)
265 (first (name-source-locations name)))
266
267 (defun name-source-locations (name)
268 (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name)))
269 (cond ((not locations)
270 (list :error (format nil "Cannot find source for ~S" name)))
271 (t
272 (loop for (dspec location) in locations
273 collect (make-dspec-location dspec location))))))
274
275 (defimplementation find-function-locations (fname)
276 (name-source-locations (from-string fname)))
277
278 ;;; Compilation
279
280 (defimplementation compile-file-for-emacs (filename load-p)
281 (let ((compiler::*error-database* '()))
282 (with-compilation-unit ()
283 (compile-file filename :load load-p)
284 (signal-error-data-base compiler::*error-database* filename)
285 (signal-undefined-functions compiler::*unknown-functions* filename))))
286
287 (defun map-error-database (database fn)
288 (loop for (filename . defs) in database do
289 (loop for (dspec . conditions) in defs do
290 (dolist (c conditions)
291 (funcall fn filename dspec c)))))
292
293 (defun lispworks-severity (condition)
294 (cond ((not condition) :warning)
295 (t (etypecase condition
296 (error :error)
297 (style-warning :warning)
298 (warning :warning)))))
299
300 (defun signal-compiler-condition (message location condition)
301 (check-type message string)
302 (signal
303 (make-instance 'compiler-condition :message message
304 :severity (lispworks-severity condition)
305 :location location
306 :original-condition condition)))
307
308 (defun compile-from-temp-file (string filename)
309 (unwind-protect
310 (progn
311 (with-open-file (s filename :direction :output :if-exists :supersede)
312 (write-string string s)
313 (finish-output s))
314 (let ((binary-filename (compile-file filename :load t)))
315 (when binary-filename
316 (delete-file binary-filename))))
317 (delete-file filename)))
318
319 ;; XXX handle all cases in dspec:*dspec-classes*
320 (defun dspec-buffer-position (dspec)
321 (etypecase dspec
322 (cons (ecase (car dspec)
323 ((defun defmacro defgeneric defvar defstruct
324 method structure package)
325 `(:function-name ,(symbol-name (cadr dspec))))
326 ;; XXX this isn't quite right
327 (lw:top-level-form `(:source-path ,(cdr dspec) nil))))
328 (symbol `(:function-name ,(symbol-name dspec)))))
329
330 (defun emacs-buffer-location-p (location)
331 (and (consp location)
332 (eq (car location) :emacs-buffer)))
333
334 (defun make-dspec-location (dspec location)
335 (flet ((filename (pathname)
336 (multiple-value-bind (truename condition)
337 (ignore-errors (truename pathname))
338 (cond (condition
339 (return-from make-dspec-location
340 (list :error (format nil "~A" condition))))
341 (t (namestring truename)))))
342 (function-name (dspec)
343 (etypecase dspec
344 (symbol (symbol-name dspec))
345 (cons (string (dspec:dspec-primary-name dspec))))))
346 (etypecase location
347 ((or pathname string)
348 (make-location `(:file ,(filename location))
349 (dspec-buffer-position 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 ((satisfies emacs-buffer-location-p)
355 (destructuring-bind (_ buffer offset string) location
356 (declare (ignore _ offset string))
357 (make-location `(:buffer ,buffer)
358 (dspec-buffer-position dspec)))))))
359
360 (defun signal-error-data-base (database location)
361 (map-error-database
362 database
363 (lambda (filename dspec condition)
364 (declare (ignore filename))
365 (signal-compiler-condition
366 (format nil "~A" condition)
367 (make-dspec-location dspec location)
368 condition))))
369
370 (defun signal-undefined-functions (htab filename)
371 (maphash (lambda (unfun dspecs)
372 (dolist (dspec dspecs)
373 (signal-compiler-condition
374 (format nil "Undefined function ~A" unfun)
375 (make-dspec-location dspec filename)
376 nil)))
377 htab))
378
379 (defimplementation compile-string-for-emacs (string &key buffer position)
380 (assert buffer)
381 (assert position)
382 (let* ((*package* *buffer-package*)
383 (location (list :emacs-buffer buffer position string))
384 (compiler::*error-database* '())
385 (tmpname (hcl:make-temp-file nil "lisp")))
386 (with-compilation-unit ()
387 (compile-from-temp-file
388 (with-standard-io-syntax
389 (format nil "~S~%~A" `(eval-when (:compile-toplevel)
390 (setq dspec::*location* (list ,@location)))
391 string))
392 tmpname)
393 (signal-error-data-base compiler::*error-database* location)
394 (signal-undefined-functions compiler::*unknown-functions* location))))
395
396 ;;; xref
397
398 (defun lookup-xrefs (finder name)
399 (xref-results-for-emacs (funcall finder (from-string name))))
400
401 (defimplementation who-calls (function-name)
402 (lookup-xrefs #'hcl:who-calls function-name))
403
404 (defimplementation who-references (variable)
405 (lookup-xrefs #'hcl:who-references variable))
406
407 (defimplementation who-binds (variable)
408 (lookup-xrefs #'hcl:who-binds variable))
409
410 (defimplementation who-sets (variable)
411 (lookup-xrefs #'hcl:who-sets variable))
412
413 (defun xref-results-for-emacs (dspecs)
414 (let ((xrefs '()))
415 (dolist (dspec dspecs)
416 (loop for (dspec location) in (dspec:find-dspec-locations dspec)
417 do (push (cons (to-string dspec)
418 (make-dspec-location dspec location))
419 xrefs)))
420 (group-xrefs xrefs)))
421
422 (defimplementation list-callers (symbol-name)
423 (lookup-xrefs #'hcl:who-calls symbol-name))
424
425 (defimplementation list-callees (symbol-name)
426 (lookup-xrefs #'hcl:calls-who symbol-name))
427
428 ;;; Inspector
429
430 (defmethod inspected-parts (o)
431 (multiple-value-bind (names values _getter _setter type)
432 (lw:get-inspector-values o nil)
433 (declare (ignore _getter _setter))
434 (values (format nil "~A~% is a ~A" o type)
435 (mapcar (lambda (name value)
436 (cons (princ-to-string name) value))
437 names values))))
438
439 ;;; Multithreading
440
441 (defimplementation startup-multiprocessing ()
442 (mp:initialize-multiprocessing))
443
444 (defimplementation spawn (fn &key name)
445 (mp:process-run-function name () fn))
446
447 (defimplementation thread-name (thread)
448 (mp:process-name thread))
449
450 (defimplementation thread-status (thread)
451 (format nil "~A ~D"
452 (mp:process-whostate thread)
453 (mp:process-priority thread)))
454
455 (defimplementation make-lock (&key name)
456 (mp:make-lock :name name))
457
458 (defimplementation call-with-lock-held (lock function)
459 (mp:with-lock (lock) (funcall function)))
460
461 (defimplementation current-thread ()
462 mp:*current-process*)
463
464 (defimplementation all-threads ()
465 (mp:list-all-processes))
466
467 (defimplementation interrupt-thread (thread fn)
468 (mp:process-interrupt thread fn))
469
470 (defimplementation kill-thread (thread)
471 (mp:process-kill thread))
472
473 (defimplementation thread-alive-p (thread)
474 (mp:process-alive-p thread))
475
476 (defvar *mailbox-lock* (mp:make-lock))
477
478 (defun mailbox (thread)
479 (mp:with-lock (*mailbox-lock*)
480 (or (getf (mp:process-plist thread) 'mailbox)
481 (setf (getf (mp:process-plist thread) 'mailbox)
482 (mp:make-mailbox)))))
483
484 (defimplementation receive ()
485 (mp:mailbox-read (mailbox mp:*current-process*)))
486
487 (defimplementation send (thread object)
488 (mp:mailbox-send (mailbox thread) object))
489

  ViewVC Help
Powered by ViewVC 1.1.5