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

Contents of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5