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

Contents of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5