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

Contents of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5