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

Contents of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5