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

Contents of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5