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

Contents of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.15 - (hide annotations)
Sun Jan 18 07:15:49 2004 UTC (10 years, 3 months ago) by heller
Branch: MAIN
Changes since 1.14: +9 -21 lines
(arglist-string): Refactor common code to swank.lisp.

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

  ViewVC Help
Powered by ViewVC 1.1.5