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

Contents of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (hide annotations)
Sun Dec 7 19:16:24 2003 UTC (10 years, 4 months ago) by heller
Branch: MAIN
Changes since 1.6: +2 -9 lines
(function-source-locations): Is replaces
function-source-location-for-emacs. Make it at generic function.
(function-source-location-for-emacs): Remove.
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.7 ;;; $Id: swank-lispworks.lisp,v 1.7 2003/12/07 19:16:24 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     (defun without-interrupts* (body)
31     (lispworks:without-interrupts (funcall body)))
32    
33     (defun create-swank-server (port &key reuse-address)
34     "Create a Swank TCP server on `port'.
35     Return the port number that the socket is actually listening on."
36     (declare (ignore reuse-address))
37     (comm:start-up-server-and-mp :announce *terminal-io* :service port
38     :process-name "Swank Request Processor"
39     :function 'swank-accept-connection
40     )
41     port)
42    
43     (defconstant +sigint+ 2)
44    
45     (defun sigint-handler (&rest args)
46     (declare (ignore args))
47     (invoke-debugger "SIGINT"))
48    
49     (defun swank-accept-connection (fd)
50     "Accept one Swank TCP connection on SOCKET and then close it.
51     Run the connection handler in a new thread."
52     (let ((*emacs-io* (make-instance 'comm:socket-stream
53     :socket fd
54     :direction :io
55     :element-type 'base-char)))
56     (sys:set-signal-handler +sigint+ #'sigint-handler)
57     (request-loop)))
58    
59     (defun request-loop ()
60     "Thread function for a single Swank connection. Processes requests
61     until the remote Emacs goes away."
62     (unwind-protect
63     (let* ((*slime-output* (make-instance 'slime-output-stream))
64     (*slime-input* (make-instance 'slime-input-stream))
65     (*slime-io* (make-two-way-stream *slime-input* *slime-output*)))
66     (loop
67     (catch 'slime-toplevel
68     (with-simple-restart (abort "Return to Slime event loop.")
69     (handler-case (read-from-emacs)
70     (slime-read-error (e)
71     (when *swank-debug-p*
72     (format *debug-io*
73     "~&;; Connection to Emacs lost.~%;; [~A]~%" e))
74     (return)))))))
75     (format *terminal-io* "~&;; Swank: Closed connection: ~A~%" *emacs-io*)
76     (close *emacs-io*)))
77    
78     (defslimefun getpid ()
79     "Return the process ID of this superior Lisp."
80     (system::getpid))
81    
82     (defmethod arglist-string (fname)
83     "Return the lambda list for function FNAME as a string."
84     (let ((*print-case* :downcase))
85     (multiple-value-bind (function condition)
86     (ignore-errors (values
87     (find-symbol-designator fname *buffer-package*)))
88     (when condition
89     (return-from arglist-string (format nil "(-- ~A)" condition)))
90     (let ((arglist (and (fboundp function)
91     (lispworks:function-lambda-list function))))
92     (if arglist
93     (princ-to-string arglist)
94     "(-- <Unknown-Function>)")))))
95    
96     (defmethod macroexpand-all (form)
97     (walker:walk-form form))
98    
99     (defmethod describe-symbol-for-emacs (symbol)
100     "Return a plist describing SYMBOL.
101     Return NIL if the symbol is unbound."
102     (let ((result '()))
103     (labels ((first-line (string)
104     (let ((pos (position #\newline string)))
105     (if (null pos) string (subseq string 0 pos))))
106     (doc (kind &optional (sym symbol))
107     (let ((string (documentation sym kind)))
108     (if string
109     (first-line string)
110     :not-documented)))
111     (maybe-push (property value)
112     (when value
113     (setf result (list* property value result)))))
114     (maybe-push
115     :variable (when (boundp symbol)
116     (doc 'variable)))
117     (maybe-push
118     :function (if (fboundp symbol)
119     (doc 'function)))
120     (maybe-push
121     :class (if (find-class symbol nil)
122     (doc 'class)))
123     (if result
124     (list* :designator (to-string symbol) result)))))
125    
126 heller 1.4 (defslimefun describe-function (symbol-name)
127     (with-output-to-string (*standard-output*)
128     (let ((sym (from-string symbol-name)))
129     (cond ((fboundp sym)
130     (format t "~%(~A~{ ~A~})~%~%~:[(not documented)~;~:*~A~]~%"
131     (string-downcase sym)
132     (mapcar #'string-upcase
133     (lispworks:function-lambda-list sym))
134     (documentation sym 'function))
135     (describe (symbol-function sym)))
136     (t (format t "~S is not fbound" sym))))))
137    
138 heller 1.1 #+(or)
139     (defmethod describe-object ((sym symbol) *standard-output*)
140     (format t "~A is a symbol in package ~A." sym (symbol-package sym))
141     (when (boundp sym)
142     (format t "~%~%Value: ~A" (symbol-value sym)))
143     (let ((doc (documentation sym 'variable)))
144     (when doc
145     (format t "~%~%Variable documentation:~%~A" doc)))
146     (when (fboundp sym)
147     (format t "~%~%(~A~{ ~A~})"
148     (string-downcase sym)
149     (mapcar #'string-upcase
150     (lispworks:function-lambda-list sym))))
151     (let ((doc (documentation sym 'function)))
152     (when doc (format t "~%~%~A~%" doc))))
153    
154     ;;; Debugging
155    
156     (defvar *sldb-restarts*)
157    
158     (defslimefun sldb-abort ()
159     (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
160    
161     (defmethod call-with-debugging-environment (fn)
162     (dbg::with-debugger-stack ()
163     (let ((*sldb-restarts* (compute-restarts *swank-debugger-condition*)))
164     (funcall fn))))
165    
166     (defun format-condition-for-emacs ()
167     (let ((*print-right-margin* 75)
168     (*print-pretty* t))
169     (format nil "~A~% [Condition of type ~S]"
170     *swank-debugger-condition* (type-of *swank-debugger-condition*))))
171    
172     (defun format-restarts-for-emacs ()
173     (loop for restart in *sldb-restarts*
174     collect (list (princ-to-string (restart-name restart))
175     (princ-to-string restart))))
176    
177     (defun interesting-frame-p (frame)
178     (or (dbg::call-frame-p frame)
179     (dbg::catch-frame-p frame)))
180    
181     (defun nth-frame (index)
182     (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*)
183     (dbg::frame-next frame))
184     (i index (if (interesting-frame-p frame) (1- i) i)))
185     ((and (interesting-frame-p frame) (zerop i)) frame)
186     (assert frame)))
187    
188     (defun compute-backtrace (start end)
189     (let ((end (or end most-positive-fixnum))
190     (backtrace '()))
191     (do ((frame (nth-frame start) (dbg::frame-next frame))
192     (i start))
193     ((or (not frame) (= i end)) (nreverse backtrace))
194     (when (interesting-frame-p frame)
195     (incf i)
196     (push frame backtrace)))))
197    
198     (defmethod backtrace (start end)
199     (flet ((format-frame (f i)
200     (with-output-to-string (*standard-output*)
201     (let ((*print-pretty* *sldb-pprint-frames*))
202     (format t "~D: ~A" i
203     (cond ((dbg::call-frame-p f)
204     (format nil "~A ~A"
205     (dbg::call-frame-function-name f)
206     (dbg::call-frame-arglist f)))
207     (t f)))))))
208     (loop for i from start
209     for f in (compute-backtrace start end)
210     collect (list i (format-frame f i)))))
211    
212     (defmethod debugger-info-for-emacs (start end)
213     (list (format-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 heller 1.5 (invoke-restart-interactively (nth-restart index)))
222 heller 1.1
223     (defmethod 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     (loop for (name value symbol location) in vars
230     collect (list :symbol symbol :id 0
231     :value-string (princ-to-string value)))))))
232    
233     (defmethod frame-catch-tags (index)
234     (declare (ignore index))
235     nil)
236    
237     (defmethod frame-source-location-for-emacs (frame)
238     (let ((frame (nth-frame frame)))
239     (if (dbg::call-frame-p frame)
240     (let ((func (dbg::call-frame-function-name frame)))
241     (if func
242     (dspec-source-location func))))))
243    
244     (defun dspec-source-location (dspec)
245 heller 1.4 (destructuring-bind (first) (dspec-source-locations dspec)
246     first))
247    
248     (defun dspec-source-locations (dspec)
249     (let ((locations (dspec:find-dspec-locations dspec)))
250 heller 1.1 (cond ((not locations)
251     (list :error (format nil "Cannot find source for ~S" dspec)))
252     (t
253 heller 1.4 (loop for (dspec location) in locations
254     collect (make-dspec-location dspec location))))))
255 heller 1.1
256 heller 1.7 (defmethod find-function-locations (fname)
257 heller 1.4 (dspec-source-locations (from-string fname)))
258    
259 heller 1.6 ;;; Tracing
260    
261     (defun tracedp (symbol)
262     (member symbol (trace) :test #'eq))
263    
264     (defslimefun toggle-trace-fdefinition (fname-string)
265     (let ((fname (from-string fname-string)))
266     (cond ((tracedp fname)
267     (compiler::ensure-untrace-1 (list fname))
268     (format nil "~S is now untraced." fname))
269     (t
270     (compiler::ensure-trace-1 (list fname))
271     (format nil "~S is now traced." fname)))))
272    
273 heller 1.1 ;;; callers
274    
275     (defun stringify-function-name-list (list)
276     (let ((*print-pretty* nil)) (mapcar #'to-string list)))
277    
278     (defslimefun list-callers (symbol-name)
279     (stringify-function-name-list (hcl:who-calls (from-string symbol-name))))
280    
281     ;;; Compilation
282    
283     (defmethod compile-file-for-emacs (filename load-p)
284     (let ((compiler::*error-database* '()))
285     (with-compilation-unit ()
286     (compile-file filename :load load-p)
287     (signal-error-data-base compiler::*error-database*)
288     (signal-undefined-functions compiler::*unknown-functions* filename))))
289    
290     (defun map-error-database (database fn)
291     (loop for (filename . defs) in database do
292     (loop for (dspec . conditions) in defs do
293     (dolist (c conditions)
294     (funcall fn filename dspec c)))))
295    
296     (defun lispworks-severity (condition)
297     (cond ((not condition) :warning)
298     (t (etypecase condition
299 heller 1.6 (error :error)
300 heller 1.1 (style-warning :warning)
301     (warning :warning)))))
302    
303     (defun signal-compiler-condition (message location condition)
304     (check-type message string)
305     (signal
306     (make-instance 'compiler-condition :message message
307     :severity (lispworks-severity condition)
308     :location location
309     :original-condition condition)))
310    
311     (defun compile-from-temp-file (string filename)
312     (unwind-protect
313     (progn
314     (with-open-file (s filename :direction :output :if-exists :supersede)
315     (write-string string s)
316     (finish-output s))
317     (let ((binary-filename (compile-file filename :load t)))
318 heller 1.6 (when binary-filename
319     (delete-file binary-filename))))
320 heller 1.1 (delete-file filename)))
321    
322 heller 1.3 (defun make-dspec-location (dspec location &optional tmpfile buffer position)
323 heller 1.4 (flet ((from-buffer-p ()
324     (and (pathnamep location) tmpfile
325     (pathname-match-p location tmpfile)))
326     (filename (pathname)
327     (multiple-value-bind (truename condition)
328     (ignore-errors (truename pathname))
329     (cond (condition
330     (return-from make-dspec-location
331     (list :error (format nil "~A" condition))))
332     (t (namestring truename)))))
333     (function-name (dspec)
334     (etypecase dspec
335     (symbol (symbol-name dspec))
336     (cons (symbol-name (dspec:dspec-primary-name dspec))))))
337     (cond ((from-buffer-p)
338     (make-location `(:buffer ,buffer) `(:position ,position)))
339     (t
340     (etypecase location
341     (pathname
342     (make-location `(:file ,(filename location))
343     `(:function-name ,(function-name dspec))))
344     ((member :listener)
345     `(:error ,(format nil "Function defined in listener: ~S" dspec)))
346     ((member :unknown)
347     `(:error ,(format nil "Function location unkown: ~S" dspec))))
348     ))))
349 heller 1.1
350     (defun signal-error-data-base (database &optional tmpfile buffer position)
351     (map-error-database
352     database
353     (lambda (filename dspec condition)
354     (signal-compiler-condition
355     (format nil "~A" condition)
356     (make-dspec-location dspec filename tmpfile buffer position)
357     condition))))
358    
359     (defun signal-undefined-functions (htab filename
360     &optional tmpfile buffer position)
361     (maphash (lambda (unfun dspecs)
362     (dolist (dspec dspecs)
363     (signal-compiler-condition
364     (format nil "Undefined function ~A" unfun)
365     (make-dspec-location dspec filename tmpfile buffer position)
366     nil)))
367     htab))
368 heller 1.2
369 heller 1.1 (defmethod compile-string-for-emacs (string &key buffer position)
370     (assert buffer)
371     (assert position)
372     (let ((*package* *buffer-package*)
373     (compiler::*error-database* '())
374     (tmpname (hcl:make-temp-file nil "lisp")))
375     (with-compilation-unit ()
376     (compile-from-temp-file string tmpname)
377 heller 1.2 (format t "~A~%" compiler:*messages*)
378 heller 1.1 (signal-error-data-base
379     compiler::*error-database* tmpname buffer position)
380     (signal-undefined-functions compiler::*unknown-functions*
381 heller 1.2 tmpname tmpname buffer position))))
382 heller 1.1
383 heller 1.3 ;;; xref
384    
385 heller 1.4 (defun lookup-xrefs (finder name)
386     (xref-results-for-emacs (funcall finder (from-string name))))
387    
388 heller 1.3 (defslimefun who-calls (function-name)
389 heller 1.4 (lookup-xrefs #'hcl:who-calls function-name))
390 heller 1.3
391     (defslimefun who-references (variable)
392 heller 1.4 (lookup-xrefs #'hcl:who-references variable))
393 heller 1.3
394     (defslimefun who-binds (variable)
395 heller 1.4 (lookup-xrefs #'hcl:who-binds variable))
396 heller 1.3
397     (defslimefun who-sets (variable)
398 heller 1.4 (lookup-xrefs #'hcl:who-sets variable))
399 heller 1.3
400     (defun xref-results-for-emacs (dspecs)
401     (let ((xrefs '()))
402     (dolist (dspec dspecs)
403     (loop for (dspec location) in (dspec:find-dspec-locations dspec)
404     do (push (cons (to-string dspec)
405     (make-dspec-location dspec location))
406     xrefs)))
407     (group-xrefs xrefs)))
408 heller 1.4
409     (defslimefun list-callers (symbol-name)
410     (lookup-xrefs #'hcl:who-calls symbol-name))
411    
412     (defslimefun list-callees (symbol-name)
413     (lookup-xrefs #'hcl:calls-who symbol-name))
414 heller 1.3
415     ;; (dspec:at-location
416     ;; ('(:inside (:buffer "foo" 34)))
417     ;; (defun foofun () (foofun)))
418    
419     ;; (dspec:find-dspec-locations 'xref-results-for-emacs)
420     ;; (who-binds '*package*)

  ViewVC Help
Powered by ViewVC 1.1.5