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

Contents of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (hide annotations)
Thu Nov 27 00:36:36 2003 UTC (10 years, 4 months ago) by heller
Branch: MAIN
First version.
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     ;;; $Id: swank-lispworks.lisp,v 1.1 2003/11/27 00:36:36 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     (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     #+(or)
127     (defmethod describe-object ((sym symbol) *standard-output*)
128     (format t "~A is a symbol in package ~A." sym (symbol-package sym))
129     (when (boundp sym)
130     (format t "~%~%Value: ~A" (symbol-value sym)))
131     (let ((doc (documentation sym 'variable)))
132     (when doc
133     (format t "~%~%Variable documentation:~%~A" doc)))
134     (when (fboundp sym)
135     (format t "~%~%(~A~{ ~A~})"
136     (string-downcase sym)
137     (mapcar #'string-upcase
138     (lispworks:function-lambda-list sym))))
139     (let ((doc (documentation sym 'function)))
140     (when doc (format t "~%~%~A~%" doc))))
141    
142     ;;; Debugging
143    
144     (defvar *sldb-restarts*)
145    
146     (defslimefun sldb-abort ()
147     (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
148    
149     (defmethod call-with-debugging-environment (fn)
150     (dbg::with-debugger-stack ()
151     (let ((*sldb-restarts* (compute-restarts *swank-debugger-condition*)))
152     (funcall fn))))
153    
154     (defun format-condition-for-emacs ()
155     (let ((*print-right-margin* 75)
156     (*print-pretty* t))
157     (format nil "~A~% [Condition of type ~S]"
158     *swank-debugger-condition* (type-of *swank-debugger-condition*))))
159    
160     (defun format-restarts-for-emacs ()
161     (loop for restart in *sldb-restarts*
162     collect (list (princ-to-string (restart-name restart))
163     (princ-to-string restart))))
164    
165     (defun interesting-frame-p (frame)
166     (or (dbg::call-frame-p frame)
167     (dbg::catch-frame-p frame)))
168    
169     (defun nth-frame (index)
170     (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*)
171     (dbg::frame-next frame))
172     (i index (if (interesting-frame-p frame) (1- i) i)))
173     ((and (interesting-frame-p frame) (zerop i)) frame)
174     (assert frame)))
175    
176     (defun compute-backtrace (start end)
177     (let ((end (or end most-positive-fixnum))
178     (backtrace '()))
179     (do ((frame (nth-frame start) (dbg::frame-next frame))
180     (i start))
181     ((or (not frame) (= i end)) (nreverse backtrace))
182     (when (interesting-frame-p frame)
183     (incf i)
184     (push frame backtrace)))))
185    
186     (defmethod backtrace (start end)
187     (flet ((format-frame (f i)
188     (with-output-to-string (*standard-output*)
189     (let ((*print-pretty* *sldb-pprint-frames*))
190     (format t "~D: ~A" i
191     (cond ((dbg::call-frame-p f)
192     (format nil "~A ~A"
193     (dbg::call-frame-function-name f)
194     (dbg::call-frame-arglist f)))
195     (t f)))))))
196     (loop for i from start
197     for f in (compute-backtrace start end)
198     collect (list i (format-frame f i)))))
199    
200     (defmethod debugger-info-for-emacs (start end)
201     (list (format-condition-for-emacs)
202     (format-restarts-for-emacs)
203     (backtrace start end)))
204    
205     (defun nth-restart (index)
206     (nth index *sldb-restarts*))
207    
208     (defslimefun invoke-nth-restart (index)
209     (let ((restart (nth-restart index)))
210     (invoke-restart restart)))
211    
212     (defmethod frame-locals (n)
213     (let ((frame (nth-frame n)))
214     (if (dbg::call-frame-p frame)
215     (destructuring-bind (vars with)
216     (dbg::frame-locals-format-list frame #'list 75 0)
217     (declare (ignore with))
218     (loop for (name value symbol location) in vars
219     collect (list :symbol symbol :id 0
220     :value-string (princ-to-string value)))))))
221    
222     (defmethod frame-catch-tags (index)
223     (declare (ignore index))
224     nil)
225    
226     (defmethod frame-source-location-for-emacs (frame)
227     (let ((frame (nth-frame frame)))
228     (if (dbg::call-frame-p frame)
229     (let ((func (dbg::call-frame-function-name frame)))
230     (if func
231     (dspec-source-location func))))))
232    
233     (defun dspec-source-location (dspec)
234     (let ((locations (dspec:dspec-definition-locations dspec)))
235     (cond ((not locations)
236     (list :error (format nil "Cannot find source for ~S" dspec)))
237     (t
238     (destructuring-bind ((dspec file) . others) locations
239     (declare (ignore others))
240     (if (eq file :unknown)
241     (list :error (format nil "Cannot find source for ~S" dspec))
242     (make-dspec-location dspec file)))))))
243    
244     (defmethod function-source-location-for-emacs (fname)
245     "Return a source position of the definition of FNAME. The
246     precise location of the definition is not available, but we are
247     able to return the file name in which the definition occurs."
248     (dspec-source-location (from-string fname)))
249    
250     ;;; callers
251    
252     (defun stringify-function-name-list (list)
253     (let ((*print-pretty* nil)) (mapcar #'to-string list)))
254    
255     (defslimefun list-callers (symbol-name)
256     (stringify-function-name-list (hcl:who-calls (from-string symbol-name))))
257    
258     ;;; Compilation
259    
260     (defmethod compile-file-for-emacs (filename load-p)
261     (let ((compiler::*error-database* '()))
262     (with-compilation-unit ()
263     (compile-file filename :load load-p)
264     (signal-error-data-base compiler::*error-database*)
265     (signal-undefined-functions compiler::*unknown-functions* filename))))
266    
267     (defun map-error-database (database fn)
268     (loop for (filename . defs) in database do
269     (loop for (dspec . conditions) in defs do
270     (dolist (c conditions)
271     (funcall fn filename dspec c)))))
272    
273     (defun lispworks-severity (condition)
274     (cond ((not condition) :warning)
275     (t (etypecase condition
276     (simple-error :error)
277     (style-warning :warning)
278     (warning :warning)))))
279    
280     (defun signal-compiler-condition (message location condition)
281     (check-type message string)
282     (signal
283     (make-instance 'compiler-condition :message message
284     :severity (lispworks-severity condition)
285     :location location
286     :original-condition condition)))
287    
288     (defun compile-from-temp-file (string filename)
289     (unwind-protect
290     (progn
291     (with-open-file (s filename :direction :output :if-exists :supersede)
292     (write-string string s)
293     (finish-output s))
294     (let ((binary-filename (compile-file filename :load t)))
295     (delete-file binary-filename)))
296     (delete-file filename)))
297    
298     (defun make-dspec-location (dspec filename &optional tmpfile buffer position)
299     (list :dspec (cond ((and tmpfile (pathname-match-p filename tmpfile))
300     (list :buffer buffer position))
301     (t (list :file (namestring filename))))
302     (string (etypecase dspec
303     (symbol dspec)
304     (cons (dspec:dspec-primary-name dspec))))))
305    
306     (defun signal-error-data-base (database &optional tmpfile buffer position)
307     (map-error-database
308     database
309     (lambda (filename dspec condition)
310     (signal-compiler-condition
311     (format nil "~A" condition)
312     (make-dspec-location dspec filename tmpfile buffer position)
313     condition))))
314    
315     (defun signal-undefined-functions (htab filename
316     &optional tmpfile buffer position)
317     (maphash (lambda (unfun dspecs)
318     (dolist (dspec dspecs)
319     (signal-compiler-condition
320     (format nil "Undefined function ~A" unfun)
321     (make-dspec-location dspec filename tmpfile buffer position)
322     nil)))
323     htab))
324    
325     (defmethod compile-string-for-emacs (string &key buffer position)
326     (assert buffer)
327     (assert position)
328     (let ((*package* *buffer-package*)
329     (compiler::*error-database* '())
330     (tmpname (hcl:make-temp-file nil "lisp")))
331     (with-compilation-unit ()
332     (compile-from-temp-file string tmpname)
333     (signal-error-data-base
334     compiler::*error-database* tmpname buffer position)
335     (signal-undefined-functions compiler::*unknown-functions*
336     tmpname tmpname buffer position))))
337    

  ViewVC Help
Powered by ViewVC 1.1.5