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

Contents of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (hide annotations)
Mon Dec 1 22:30:16 2003 UTC (10 years, 4 months ago) by heller
Branch: MAIN
Changes since 1.4: +2 -3 lines
(invoke-nth-restart): Use invoke-restart-interactively.
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.5 ;;; $Id: swank-lispworks.lisp,v 1.5 2003/12/01 22:30:16 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     (defmethod function-source-location-for-emacs (fname)
257     "Return a source position of the definition of FNAME. The
258     precise location of the definition is not available, but we are
259     able to return the file name in which the definition occurs."
260     (dspec-source-location (from-string fname)))
261    
262 heller 1.4 (defslimefun find-function-locations (fname)
263     (dspec-source-locations (from-string fname)))
264    
265 heller 1.1 ;;; callers
266    
267     (defun stringify-function-name-list (list)
268     (let ((*print-pretty* nil)) (mapcar #'to-string list)))
269    
270     (defslimefun list-callers (symbol-name)
271     (stringify-function-name-list (hcl:who-calls (from-string symbol-name))))
272    
273     ;;; Compilation
274    
275     (defmethod compile-file-for-emacs (filename load-p)
276     (let ((compiler::*error-database* '()))
277     (with-compilation-unit ()
278     (compile-file filename :load load-p)
279     (signal-error-data-base compiler::*error-database*)
280     (signal-undefined-functions compiler::*unknown-functions* filename))))
281    
282     (defun map-error-database (database fn)
283     (loop for (filename . defs) in database do
284     (loop for (dspec . conditions) in defs do
285     (dolist (c conditions)
286     (funcall fn filename dspec c)))))
287    
288     (defun lispworks-severity (condition)
289     (cond ((not condition) :warning)
290     (t (etypecase condition
291     (simple-error :error)
292     (style-warning :warning)
293     (warning :warning)))))
294    
295     (defun signal-compiler-condition (message location condition)
296     (check-type message string)
297     (signal
298     (make-instance 'compiler-condition :message message
299     :severity (lispworks-severity condition)
300     :location location
301     :original-condition condition)))
302    
303     (defun compile-from-temp-file (string filename)
304     (unwind-protect
305     (progn
306     (with-open-file (s filename :direction :output :if-exists :supersede)
307     (write-string string s)
308     (finish-output s))
309     (let ((binary-filename (compile-file filename :load t)))
310     (delete-file binary-filename)))
311     (delete-file filename)))
312    
313 heller 1.3 (defun make-dspec-location (dspec location &optional tmpfile buffer position)
314 heller 1.4 (flet ((from-buffer-p ()
315     (and (pathnamep location) tmpfile
316     (pathname-match-p location tmpfile)))
317     (filename (pathname)
318     (multiple-value-bind (truename condition)
319     (ignore-errors (truename pathname))
320     (cond (condition
321     (return-from make-dspec-location
322     (list :error (format nil "~A" condition))))
323     (t (namestring truename)))))
324     (function-name (dspec)
325     (etypecase dspec
326     (symbol (symbol-name dspec))
327     (cons (symbol-name (dspec:dspec-primary-name dspec))))))
328     (cond ((from-buffer-p)
329     (make-location `(:buffer ,buffer) `(:position ,position)))
330     (t
331     (etypecase location
332     (pathname
333     (make-location `(:file ,(filename location))
334     `(:function-name ,(function-name dspec))))
335     ((member :listener)
336     `(:error ,(format nil "Function defined in listener: ~S" dspec)))
337     ((member :unknown)
338     `(:error ,(format nil "Function location unkown: ~S" dspec))))
339     ))))
340 heller 1.1
341     (defun signal-error-data-base (database &optional tmpfile buffer position)
342     (map-error-database
343     database
344     (lambda (filename dspec condition)
345     (signal-compiler-condition
346     (format nil "~A" condition)
347     (make-dspec-location dspec filename tmpfile buffer position)
348     condition))))
349    
350     (defun signal-undefined-functions (htab filename
351     &optional tmpfile buffer position)
352     (maphash (lambda (unfun dspecs)
353     (dolist (dspec dspecs)
354     (signal-compiler-condition
355     (format nil "Undefined function ~A" unfun)
356     (make-dspec-location dspec filename tmpfile buffer position)
357     nil)))
358     htab))
359 heller 1.2
360 heller 1.1 (defmethod compile-string-for-emacs (string &key buffer position)
361     (assert buffer)
362     (assert position)
363     (let ((*package* *buffer-package*)
364     (compiler::*error-database* '())
365     (tmpname (hcl:make-temp-file nil "lisp")))
366     (with-compilation-unit ()
367     (compile-from-temp-file string tmpname)
368 heller 1.2 (format t "~A~%" compiler:*messages*)
369 heller 1.1 (signal-error-data-base
370     compiler::*error-database* tmpname buffer position)
371     (signal-undefined-functions compiler::*unknown-functions*
372 heller 1.2 tmpname tmpname buffer position))))
373 heller 1.1
374 heller 1.3 ;;; xref
375    
376 heller 1.4 (defun lookup-xrefs (finder name)
377     (xref-results-for-emacs (funcall finder (from-string name))))
378    
379 heller 1.3 (defslimefun who-calls (function-name)
380 heller 1.4 (lookup-xrefs #'hcl:who-calls function-name))
381 heller 1.3
382     (defslimefun who-references (variable)
383 heller 1.4 (lookup-xrefs #'hcl:who-references variable))
384 heller 1.3
385     (defslimefun who-binds (variable)
386 heller 1.4 (lookup-xrefs #'hcl:who-binds variable))
387 heller 1.3
388     (defslimefun who-sets (variable)
389 heller 1.4 (lookup-xrefs #'hcl:who-sets variable))
390 heller 1.3
391     (defun xref-results-for-emacs (dspecs)
392     (let ((xrefs '()))
393     (dolist (dspec dspecs)
394     (loop for (dspec location) in (dspec:find-dspec-locations dspec)
395     do (push (cons (to-string dspec)
396     (make-dspec-location dspec location))
397     xrefs)))
398     (group-xrefs xrefs)))
399 heller 1.4
400     (defslimefun list-callers (symbol-name)
401     (lookup-xrefs #'hcl:who-calls symbol-name))
402    
403     (defslimefun list-callees (symbol-name)
404     (lookup-xrefs #'hcl:calls-who symbol-name))
405 heller 1.3
406     ;; (dspec:at-location
407     ;; ('(:inside (:buffer "foo" 34)))
408     ;; (defun foofun () (foofun)))
409    
410     ;; (dspec:find-dspec-locations 'xref-results-for-emacs)
411     ;; (who-binds '*package*)

  ViewVC Help
Powered by ViewVC 1.1.5