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

Contents of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5