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

Contents of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5