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

Contents of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12 - (show annotations)
Tue Jan 13 04:22:20 2004 UTC (10 years, 3 months ago) by lgorrie
Branch: MAIN
Changes since 1.11: +33 -37 lines
Updated for new network interface.

(accept-socket/stream): This function is currently broken, so
LispWorks can't use the dedicated output channel at the moment.
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.12 2004/01/13 04:22:20 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 (defun without-interrupts* (body)
31 (lispworks:without-interrupts (funcall body)))
32
33 (defconstant +sigint+ 2)
34
35 (defmethod accept-socket/run (&key (port 0) announce-fn init-fn)
36 (flet ((sentinel (socket condition)
37 (when socket
38 (funcall announce-fn (local-tcp-port socket))))
39 (accept (socket)
40 (let ((handler-fn (funcall init-fn (make-socket-stream socket))))
41 (loop while t do (funcall handler-fn)))))
42 (comm:start-up-server :announce #'sentinel
43 :service port
44 :process-name "Swank server"
45 :function #'accept)))
46
47 ;;; FIXME: Broken. Why?
48 (defmethod accept-socket/stream (&key (port 0) announce-fn)
49 (let ((mbox (mp:make-mailbox)))
50 (flet ((init (stream)
51 (mp:mailbox-send mbox stream)
52 (mp:process-kill mp:*current-process*)))
53 (accept-socket/run :port port :announce-fn announce-fn :init-fn #'init)
54 (mp:mailbox-read mbox "Waiting for socket stream"))))
55
56 (defun make-socket-stream (socket)
57 (make-instance 'comm:socket-stream
58 :socket socket
59 :direction :io
60 :element-type 'base-char))
61
62 (defun local-tcp-port (socket)
63 (nth-value 1 (comm:get-socket-address socket)))
64
65 (defmethod emacs-connected ()
66 ;; Set SIGINT handler on Swank request handler thread.
67 (sys:set-signal-handler +sigint+ #'sigint-handler))
68
69 (defun sigint-handler (&rest args)
70 (declare (ignore args))
71 (invoke-debugger "SIGINT"))
72
73 (defmethod make-fn-streams (input-fn output-fn)
74 (let* ((output (make-instance 'slime-output-stream
75 :output-fn output-fn))
76 (input (make-instance 'slime-input-stream
77 :input-fn input-fn
78 :output-stream output)))
79 (values input output)))
80
81
82 (defslimefun getpid ()
83 "Return the process ID of this superior Lisp."
84 (system::getpid))
85
86 (defmethod arglist-string (fname)
87 "Return the lambda list for function FNAME as a string."
88 (let ((*print-case* :downcase))
89 (multiple-value-bind (function condition)
90 (ignore-errors (values
91 (find-symbol-designator fname *buffer-package*)))
92 (when condition
93 (return-from arglist-string (format nil "(-- ~A)" condition)))
94 (let ((arglist (and (fboundp function)
95 (lispworks:function-lambda-list function))))
96 (if arglist
97 (princ-to-string arglist)
98 "(-- <Unknown-Function>)")))))
99
100 (defmethod macroexpand-all (form)
101 (walker:walk-form form))
102
103 (defmethod describe-symbol-for-emacs (symbol)
104 "Return a plist describing SYMBOL.
105 Return NIL if the symbol is unbound."
106 (let ((result '()))
107 (labels ((first-line (string)
108 (let ((pos (position #\newline string)))
109 (if (null pos) string (subseq string 0 pos))))
110 (doc (kind &optional (sym symbol))
111 (let ((string (documentation sym kind)))
112 (if string
113 (first-line string)
114 :not-documented)))
115 (maybe-push (property value)
116 (when value
117 (setf result (list* property value result)))))
118 (maybe-push
119 :variable (when (boundp symbol)
120 (doc 'variable)))
121 (maybe-push
122 :function (if (fboundp symbol)
123 (doc 'function)))
124 (maybe-push
125 :class (if (find-class symbol nil)
126 (doc 'class)))
127 (if result
128 (list* :designator (to-string symbol) result)))))
129
130 (defslimefun 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 (defmethod 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
162 (defslimefun sldb-abort ()
163 (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
164
165 (defmethod call-with-debugging-environment (fn)
166 (dbg::with-debugger-stack ()
167 (let ((*sldb-restarts* (compute-restarts *swank-debugger-condition*)))
168 (funcall fn))))
169
170 (defun format-restarts-for-emacs ()
171 (loop for restart in *sldb-restarts*
172 collect (list (princ-to-string (restart-name restart))
173 (princ-to-string restart))))
174
175 (defun interesting-frame-p (frame)
176 (or (dbg::call-frame-p frame)
177 (dbg::catch-frame-p frame)))
178
179 (defun nth-frame (index)
180 (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*)
181 (dbg::frame-next frame))
182 (i index (if (interesting-frame-p frame) (1- i) i)))
183 ((and (interesting-frame-p frame) (zerop i)) frame)
184 (assert frame)))
185
186 (defun compute-backtrace (start end)
187 (let ((end (or end most-positive-fixnum))
188 (backtrace '()))
189 (do ((frame (nth-frame start) (dbg::frame-next frame))
190 (i start))
191 ((or (not frame) (= i end)) (nreverse backtrace))
192 (when (interesting-frame-p frame)
193 (incf i)
194 (push frame backtrace)))))
195
196 (defmethod backtrace (start end)
197 (flet ((format-frame (f i)
198 (print-with-frame-label
199 i (lambda (s)
200 (cond ((dbg::call-frame-p f)
201 (format s "~A ~A"
202 (dbg::call-frame-function-name f)
203 (dbg::call-frame-arglist f)))
204 (t (princ f s)))))))
205 (loop for i from start
206 for f in (compute-backtrace start end)
207 collect (list i (format-frame f i)))))
208
209 (defmethod debugger-info-for-emacs (start end)
210 (list (debugger-condition-for-emacs)
211 (format-restarts-for-emacs)
212 (backtrace start end)))
213
214 (defun nth-restart (index)
215 (nth index *sldb-restarts*))
216
217 (defslimefun invoke-nth-restart (index)
218 (invoke-restart-interactively (nth-restart index)))
219
220 (defmethod frame-locals (n)
221 (let ((frame (nth-frame n)))
222 (if (dbg::call-frame-p frame)
223 (destructuring-bind (vars with)
224 (dbg::frame-locals-format-list frame #'list 75 0)
225 (declare (ignore with))
226 (loop for (name value symbol location) in vars
227 collect (list :name (to-string symbol) :id 0
228 :value-string (princ-to-string value)))))))
229
230 (defmethod frame-catch-tags (index)
231 (declare (ignore index))
232 nil)
233
234 (defmethod frame-source-location-for-emacs (frame)
235 (let ((frame (nth-frame frame)))
236 (if (dbg::call-frame-p frame)
237 (let ((func (dbg::call-frame-function-name frame)))
238 (if func
239 (dspec-source-location func))))))
240
241 (defun dspec-source-location (dspec)
242 (destructuring-bind (first) (dspec-source-locations dspec)
243 first))
244
245 (defun dspec-source-locations (dspec)
246 (let ((locations (dspec:find-dspec-locations dspec)))
247 (cond ((not locations)
248 (list :error (format nil "Cannot find source for ~S" dspec)))
249 (t
250 (loop for (dspec location) in locations
251 collect (make-dspec-location dspec location))))))
252
253 (defmethod find-function-locations (fname)
254 (dspec-source-locations (from-string fname)))
255
256 ;;; callers
257
258 (defun stringify-function-name-list (list)
259 (let ((*print-pretty* nil)) (mapcar #'to-string list)))
260
261 (defslimefun list-callers (symbol-name)
262 (stringify-function-name-list (hcl:who-calls (from-string symbol-name))))
263
264 ;;; Compilation
265
266 (defmethod compile-file-for-emacs (filename load-p)
267 (let ((compiler::*error-database* '()))
268 (with-compilation-unit ()
269 (compile-file filename :load load-p)
270 (signal-error-data-base compiler::*error-database*)
271 (signal-undefined-functions compiler::*unknown-functions* filename))))
272
273 (defun map-error-database (database fn)
274 (loop for (filename . defs) in database do
275 (loop for (dspec . conditions) in defs do
276 (dolist (c conditions)
277 (funcall fn filename dspec c)))))
278
279 (defun lispworks-severity (condition)
280 (cond ((not condition) :warning)
281 (t (etypecase condition
282 (error :error)
283 (style-warning :warning)
284 (warning :warning)))))
285
286 (defun signal-compiler-condition (message location condition)
287 (check-type message string)
288 (signal
289 (make-instance 'compiler-condition :message message
290 :severity (lispworks-severity condition)
291 :location location
292 :original-condition condition)))
293
294 (defun compile-from-temp-file (string filename)
295 (unwind-protect
296 (progn
297 (with-open-file (s filename :direction :output :if-exists :supersede)
298 (write-string string s)
299 (finish-output s))
300 (let ((binary-filename (compile-file filename :load t)))
301 (when binary-filename
302 (delete-file binary-filename))))
303 (delete-file filename)))
304
305 (defun make-dspec-location (dspec location &optional tmpfile buffer position)
306 (flet ((from-buffer-p ()
307 (and (pathnamep location) tmpfile
308 (pathname-match-p location tmpfile)))
309 (filename (pathname)
310 (multiple-value-bind (truename condition)
311 (ignore-errors (truename pathname))
312 (cond (condition
313 (return-from make-dspec-location
314 (list :error (format nil "~A" condition))))
315 (t (namestring truename)))))
316 (function-name (dspec)
317 (etypecase dspec
318 (symbol (symbol-name dspec))
319 (cons (symbol-name (dspec:dspec-primary-name dspec))))))
320 (cond ((from-buffer-p)
321 (make-location `(:buffer ,buffer) `(:position ,position)))
322 (t
323 (etypecase location
324 (pathname
325 (make-location `(:file ,(filename location))
326 `(:function-name ,(function-name dspec))))
327 ((member :listener)
328 `(:error ,(format nil "Function defined in listener: ~S" dspec)))
329 ((member :unknown)
330 `(:error ,(format nil "Function location unkown: ~S" dspec))))
331 ))))
332
333 (defun signal-error-data-base (database &optional tmpfile buffer position)
334 (map-error-database
335 database
336 (lambda (filename dspec condition)
337 (signal-compiler-condition
338 (format nil "~A" condition)
339 (make-dspec-location dspec filename tmpfile buffer position)
340 condition))))
341
342 (defun signal-undefined-functions (htab filename
343 &optional tmpfile buffer position)
344 (maphash (lambda (unfun dspecs)
345 (dolist (dspec dspecs)
346 (signal-compiler-condition
347 (format nil "Undefined function ~A" unfun)
348 (make-dspec-location dspec filename tmpfile buffer position)
349 nil)))
350 htab))
351
352 (defmethod compile-string-for-emacs (string &key buffer position)
353 (assert buffer)
354 (assert position)
355 (let ((*package* *buffer-package*)
356 (compiler::*error-database* '())
357 (tmpname (hcl:make-temp-file nil "lisp")))
358 (with-compilation-unit ()
359 (compile-from-temp-file string tmpname)
360 (format t "~A~%" compiler:*messages*)
361 (signal-error-data-base
362 compiler::*error-database* tmpname buffer position)
363 (signal-undefined-functions compiler::*unknown-functions*
364 tmpname tmpname buffer position))))
365
366 ;;; xref
367
368 (defun lookup-xrefs (finder name)
369 (xref-results-for-emacs (funcall finder (from-string name))))
370
371 (defslimefun who-calls (function-name)
372 (lookup-xrefs #'hcl:who-calls function-name))
373
374 (defslimefun who-references (variable)
375 (lookup-xrefs #'hcl:who-references variable))
376
377 (defslimefun who-binds (variable)
378 (lookup-xrefs #'hcl:who-binds variable))
379
380 (defslimefun who-sets (variable)
381 (lookup-xrefs #'hcl:who-sets variable))
382
383 (defun xref-results-for-emacs (dspecs)
384 (let ((xrefs '()))
385 (dolist (dspec dspecs)
386 (loop for (dspec location) in (dspec:find-dspec-locations dspec)
387 do (push (cons (to-string dspec)
388 (make-dspec-location dspec location))
389 xrefs)))
390 (group-xrefs xrefs)))
391
392 (defslimefun list-callers (symbol-name)
393 (lookup-xrefs #'hcl:who-calls symbol-name))
394
395 (defslimefun list-callees (symbol-name)
396 (lookup-xrefs #'hcl:calls-who symbol-name))
397
398 ;; (dspec:at-location
399 ;; ('(:inside (:buffer "foo" 34)))
400 ;; (defun foofun () (foofun)))
401
402 ;; (dspec:find-dspec-locations 'xref-results-for-emacs)
403 ;; (who-binds '*package*)

  ViewVC Help
Powered by ViewVC 1.1.5