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

Contents of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.34 - (hide annotations)
Wed Mar 10 09:10:33 2004 UTC (10 years, 1 month ago) by heller
Branch: MAIN
Changes since 1.33: +12 -5 lines
more tweaking.
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 heller 1.30 (in-package :swank-backend)
12 heller 1.1
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.30 (defimplementation preferred-communication-style ()
31     :spawn)
32 heller 1.18
33 heller 1.13 (defun socket-fd (socket)
34     (etypecase socket
35     (fixnum socket)
36     (comm:socket-stream (comm:socket-stream-socket socket))))
37    
38 heller 1.22 (defimplementation create-socket (host port)
39 heller 1.13 (multiple-value-bind (socket where errno)
40 heller 1.22 (comm::create-tcp-socket-for-service port :address host)
41 heller 1.13 (cond (socket socket)
42 heller 1.14 (t (error 'network-error
43 heller 1.13 :format-control "~A failed: ~A (~D)"
44     :format-arguments (list where
45     (list #+unix (lw:get-unix-error errno))
46 heller 1.14 errno))))))
47 heller 1.13
48 lgorrie 1.17 (defimplementation local-port (socket)
49 heller 1.13 (nth-value 1 (comm:get-socket-address (socket-fd socket))))
50    
51 lgorrie 1.17 (defimplementation close-socket (socket)
52 heller 1.13 (comm::close-socket (socket-fd socket)))
53    
54 lgorrie 1.17 (defimplementation accept-connection (socket)
55 heller 1.13 (let ((fd (comm::get-fd-from-socket socket)))
56     (assert (/= fd -1))
57     (make-instance 'comm:socket-stream :socket fd :direction :io
58     :element-type 'base-char)))
59    
60 lgorrie 1.17 (defimplementation emacs-connected ()
61 lgorrie 1.12 ;; Set SIGINT handler on Swank request handler thread.
62 heller 1.29 #-win32
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.29 (defimplementation getpid ()
80     #+win32 (win32:get-current-process-id)
81     #-win32 (system::getpid))
82 heller 1.1
83 heller 1.23 (defimplementation lisp-implementation-type-name ()
84     "lispworks")
85    
86 heller 1.30 (defimplementation arglist (symbol)
87     (let ((arglist (lw:function-lambda-list symbol)))
88     (etypecase arglist
89     ((member :dont-know)
90     (error "<arglist-unavailable>"))
91     (list arglist))))
92 heller 1.1
93 lgorrie 1.17 (defimplementation macroexpand-all (form)
94 heller 1.1 (walker:walk-form form))
95    
96 lgorrie 1.17 (defimplementation describe-symbol-for-emacs (symbol)
97 heller 1.1 "Return a plist describing SYMBOL.
98     Return NIL if the symbol is unbound."
99     (let ((result '()))
100     (labels ((first-line (string)
101     (let ((pos (position #\newline string)))
102     (if (null pos) string (subseq string 0 pos))))
103     (doc (kind &optional (sym symbol))
104     (let ((string (documentation sym kind)))
105     (if string
106     (first-line string)
107     :not-documented)))
108     (maybe-push (property value)
109     (when value
110     (setf result (list* property value result)))))
111     (maybe-push
112     :variable (when (boundp symbol)
113     (doc 'variable)))
114     (maybe-push
115     :function (if (fboundp symbol)
116     (doc 'function)))
117     (maybe-push
118     :class (if (find-class symbol nil)
119     (doc 'class)))
120 heller 1.30 result)))
121 heller 1.1
122 heller 1.30 (defimplementation describe-definition (symbol type)
123     (ecase type
124     (:variable (describe-symbol symbol))
125     (:class (describe (find-class symbol)))
126     (:function (describe-function symbol))))
127    
128     (defun describe-function (symbol)
129     (cond ((fboundp symbol)
130     (format t "~%(~A~{ ~A~})~%~%~:[(not documented)~;~:*~A~]~%"
131     (string-downcase symbol)
132     (mapcar #'string-upcase
133     (lispworks:function-lambda-list symbol))
134     (documentation symbol 'function))
135     (describe (symbol-function symbol)))
136     (t (format t "~S is not fbound" symbol))))
137 heller 1.4
138 heller 1.30 (defun describe-symbol (sym)
139 heller 1.1 (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 heller 1.30 (describe-function sym)))
147 heller 1.1
148     ;;; Debugging
149    
150 heller 1.26 (defvar *sldb-top-frame*)
151 heller 1.1
152 lgorrie 1.17 (defimplementation call-with-debugging-environment (fn)
153 heller 1.1 (dbg::with-debugger-stack ()
154 heller 1.30 (let ((*sldb-top-frame* (dbg::debugger-stack-current-frame
155 heller 1.26 dbg::*debugger-stack*)))
156 heller 1.1 (funcall fn))))
157    
158     (defun interesting-frame-p (frame)
159     (or (dbg::call-frame-p frame)
160 heller 1.33 (dbg::derived-call-frame-p frame)
161     (dbg::foreign-frame-p frame)
162     (dbg::interpreted-call-frame-p frame)
163 heller 1.19 ;;(dbg::catch-frame-p frame)
164     ))
165 heller 1.1
166     (defun nth-frame (index)
167 heller 1.26 (do ((frame *sldb-top-frame* (dbg::frame-next frame))
168 heller 1.1 (i index (if (interesting-frame-p frame) (1- i) i)))
169     ((and (interesting-frame-p frame) (zerop i)) frame)
170     (assert frame)))
171    
172 heller 1.30 (defimplementation compute-backtrace (start end)
173 heller 1.1 (let ((end (or end most-positive-fixnum))
174     (backtrace '()))
175     (do ((frame (nth-frame start) (dbg::frame-next frame))
176     (i start))
177     ((or (not frame) (= i end)) (nreverse backtrace))
178     (when (interesting-frame-p frame)
179     (incf i)
180     (push frame backtrace)))))
181    
182 heller 1.30 (defimplementation print-frame (frame stream)
183     (cond ((dbg::call-frame-p frame)
184     (format stream "~A ~A"
185     (dbg::call-frame-function-name frame)
186     (dbg::call-frame-arglist frame)))
187     (t (princ frame stream))))
188 heller 1.1
189 lgorrie 1.17 (defimplementation frame-locals (n)
190 heller 1.29 (let ((frame (nth-frame n)))
191 heller 1.1 (if (dbg::call-frame-p frame)
192     (destructuring-bind (vars with)
193     (dbg::frame-locals-format-list frame #'list 75 0)
194     (declare (ignore with))
195 heller 1.21 (mapcar (lambda (var)
196     (destructuring-bind (name value symbol location) var
197     (declare (ignore name location))
198 mbaringer 1.28 (list :name symbol :id 0
199     :value value)))
200 heller 1.21 vars)))))
201 heller 1.1
202 lgorrie 1.17 (defimplementation frame-catch-tags (index)
203 heller 1.1 (declare (ignore index))
204     nil)
205    
206 lgorrie 1.17 (defimplementation frame-source-location-for-emacs (frame)
207 heller 1.1 (let ((frame (nth-frame frame)))
208     (if (dbg::call-frame-p frame)
209 heller 1.33 (let ((name (dbg::call-frame-function-name frame)))
210     (if name
211     (function-name-location name))))))
212 heller 1.26
213     (defimplementation eval-in-frame (form frame-number)
214     (let ((frame (nth-frame frame-number)))
215     (dbg::dbg-eval form frame)))
216    
217     (defimplementation return-from-frame (frame-number form)
218     (let* ((frame (nth-frame frame-number))
219 heller 1.30 (return-frame (dbg::find-frame-for-return frame)))
220 heller 1.26 (dbg::dbg-return-from-call-frame frame form return-frame
221     dbg::*debugger-stack*)))
222    
223     (defimplementation restart-frame (frame-number)
224     (let ((frame (nth-frame frame-number)))
225     (dbg::restart-frame frame :same-args t)))
226 heller 1.1
227 heller 1.18 ;;; Definition finding
228    
229 heller 1.33 (defun function-name-location (name)
230     (let ((defs (find-definitions name)))
231     (cond (defs (cadr (first defs)))
232     (t (list :error (format nil "Source location not available for: ~S"
233     name))))))
234 heller 1.4
235 heller 1.33 (defimplementation find-definitions (name)
236 heller 1.26 (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name)))
237 heller 1.33 (loop for (dspec location) in locations
238     collect (list dspec (make-dspec-location dspec location)))))
239 heller 1.6
240 heller 1.18 ;;; Compilation
241    
242 heller 1.30 (defimplementation swank-compile-file (filename load-p)
243 heller 1.1 (let ((compiler::*error-database* '()))
244     (with-compilation-unit ()
245     (compile-file filename :load load-p)
246 heller 1.26 (signal-error-data-base compiler::*error-database* filename)
247 heller 1.1 (signal-undefined-functions compiler::*unknown-functions* filename))))
248    
249     (defun map-error-database (database fn)
250     (loop for (filename . defs) in database do
251     (loop for (dspec . conditions) in defs do
252     (dolist (c conditions)
253     (funcall fn filename dspec c)))))
254    
255     (defun lispworks-severity (condition)
256     (cond ((not condition) :warning)
257     (t (etypecase condition
258 heller 1.6 (error :error)
259 heller 1.1 (style-warning :warning)
260     (warning :warning)))))
261    
262     (defun signal-compiler-condition (message location condition)
263     (check-type message string)
264     (signal
265     (make-instance 'compiler-condition :message message
266     :severity (lispworks-severity condition)
267     :location location
268     :original-condition condition)))
269    
270     (defun compile-from-temp-file (string filename)
271     (unwind-protect
272     (progn
273     (with-open-file (s filename :direction :output :if-exists :supersede)
274     (write-string string s)
275     (finish-output s))
276     (let ((binary-filename (compile-file filename :load t)))
277 heller 1.6 (when binary-filename
278     (delete-file binary-filename))))
279 heller 1.1 (delete-file filename)))
280    
281 heller 1.34 (defun dspec-buffer-position (dspec offset)
282     (etypecase dspec
283     (cons (let ((name (dspec:dspec-primary-name dspec)))
284     (etypecase name
285     ((or symbol string)
286     (list :function-name (string name)))
287     (t (list :position offset)))))
288     (null (list :position offset))
289     (symbol (list :function-name (string dspec)))))
290 heller 1.18
291 heller 1.25 (defun emacs-buffer-location-p (location)
292     (and (consp location)
293     (eq (car location) :emacs-buffer)))
294    
295 heller 1.26 (defun make-dspec-location (dspec location)
296     (flet ((filename (pathname)
297 heller 1.4 (multiple-value-bind (truename condition)
298     (ignore-errors (truename pathname))
299     (cond (condition
300     (return-from make-dspec-location
301     (list :error (format nil "~A" condition))))
302     (t (namestring truename)))))
303     (function-name (dspec)
304     (etypecase dspec
305     (symbol (symbol-name dspec))
306 heller 1.18 (cons (string (dspec:dspec-primary-name dspec))))))
307 heller 1.26 (etypecase location
308     ((or pathname string)
309     (make-location `(:file ,(filename location))
310 heller 1.34 (dspec-buffer-position dspec 1)))
311 heller 1.33 (symbol `(:error ,(format nil "Cannot resolve location: ~S" location)))
312 heller 1.26 ((satisfies emacs-buffer-location-p)
313     (destructuring-bind (_ buffer offset string) location
314 heller 1.34 (declare (ignore _ string))
315 heller 1.26 (make-location `(:buffer ,buffer)
316 heller 1.34 (dspec-buffer-position dspec offset)))))))
317 heller 1.1
318 heller 1.26 (defun signal-error-data-base (database location)
319 heller 1.1 (map-error-database
320     database
321     (lambda (filename dspec condition)
322 heller 1.26 (declare (ignore filename))
323 heller 1.1 (signal-compiler-condition
324     (format nil "~A" condition)
325 heller 1.26 (make-dspec-location dspec location)
326 heller 1.1 condition))))
327    
328 heller 1.26 (defun signal-undefined-functions (htab filename)
329 heller 1.1 (maphash (lambda (unfun dspecs)
330     (dolist (dspec dspecs)
331     (signal-compiler-condition
332     (format nil "Undefined function ~A" unfun)
333 heller 1.26 (make-dspec-location dspec filename)
334 heller 1.1 nil)))
335     htab))
336 heller 1.2
337 heller 1.30 (defimplementation swank-compile-string (string &key buffer position)
338 heller 1.1 (assert buffer)
339     (assert position)
340 heller 1.30 (let* ((location (list :emacs-buffer buffer position string))
341 heller 1.26 (compiler::*error-database* '())
342     (tmpname (hcl:make-temp-file nil "lisp")))
343 heller 1.1 (with-compilation-unit ()
344 heller 1.26 (compile-from-temp-file
345     (with-standard-io-syntax
346     (format nil "~S~%~A" `(eval-when (:compile-toplevel)
347     (setq dspec::*location* (list ,@location)))
348     string))
349     tmpname)
350     (signal-error-data-base compiler::*error-database* location)
351     (signal-undefined-functions compiler::*unknown-functions* location))))
352 heller 1.1
353 heller 1.3 ;;; xref
354    
355 heller 1.31 (defmacro defxref (name function)
356     `(defimplementation ,name (name)
357     (xref-results (,function name))))
358    
359     (defxref who-calls hcl:who-calls)
360     (defxref who-references hcl:who-references)
361     (defxref who-binds hcl:who-binds)
362     (defxref who-sets hcl:who-sets)
363     (defxref list-callees hcl:calls-who)
364    
365     (defun xref-results (dspecs)
366     (loop for dspec in dspecs
367     nconc (loop for (dspec location) in
368     (dspec:dspec-definition-locations dspec)
369     collect (list dspec
370     (make-dspec-location dspec location)))))
371 heller 1.25 ;;; Inspector
372    
373     (defmethod inspected-parts (o)
374     (multiple-value-bind (names values _getter _setter type)
375     (lw:get-inspector-values o nil)
376     (declare (ignore _getter _setter))
377     (values (format nil "~A~% is a ~A" o type)
378     (mapcar (lambda (name value)
379     (cons (princ-to-string name) value))
380     names values))))
381    
382 heller 1.16 ;;; Multithreading
383    
384 heller 1.18 (defimplementation startup-multiprocessing ()
385 heller 1.16 (mp:initialize-multiprocessing))
386    
387 heller 1.18 (defimplementation spawn (fn &key name)
388 heller 1.16 (mp:process-run-function name () fn))
389    
390 heller 1.21 (defimplementation thread-name (thread)
391     (mp:process-name thread))
392 heller 1.16
393 heller 1.21 (defimplementation thread-status (thread)
394     (format nil "~A ~D"
395     (mp:process-whostate thread)
396     (mp:process-priority thread)))
397 heller 1.16
398 heller 1.18 (defimplementation make-lock (&key name)
399 heller 1.16 (mp:make-lock :name name))
400    
401 heller 1.18 (defimplementation call-with-lock-held (lock function)
402 heller 1.16 (mp:with-lock (lock) (funcall function)))
403 heller 1.20
404     (defimplementation current-thread ()
405     mp:*current-process*)
406 heller 1.21
407     (defimplementation all-threads ()
408     (mp:list-all-processes))
409 heller 1.20
410     (defimplementation interrupt-thread (thread fn)
411     (mp:process-interrupt thread fn))
412 heller 1.25
413     (defimplementation kill-thread (thread)
414     (mp:process-kill thread))
415 heller 1.27
416     (defimplementation thread-alive-p (thread)
417     (mp:process-alive-p thread))
418 heller 1.20
419     (defvar *mailbox-lock* (mp:make-lock))
420    
421     (defun mailbox (thread)
422     (mp:with-lock (*mailbox-lock*)
423     (or (getf (mp:process-plist thread) 'mailbox)
424     (setf (getf (mp:process-plist thread) 'mailbox)
425     (mp:make-mailbox)))))
426    
427     (defimplementation receive ()
428     (mp:mailbox-read (mailbox mp:*current-process*)))
429    
430     (defimplementation send (thread object)
431     (mp:mailbox-send (mailbox thread) object))
432 heller 1.3

  ViewVC Help
Powered by ViewVC 1.1.5