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

Contents of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.32 - (hide annotations)
Tue Mar 9 20:07:58 2004 UTC (10 years, 1 month ago) by heller
Branch: MAIN
Changes since 1.31: +0 -28 lines
Remove stupid conflicts.
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.19 ;;(dbg::catch-frame-p frame)
161     ))
162 heller 1.1
163     (defun nth-frame (index)
164 heller 1.26 (do ((frame *sldb-top-frame* (dbg::frame-next frame))
165 heller 1.1 (i index (if (interesting-frame-p frame) (1- i) i)))
166     ((and (interesting-frame-p frame) (zerop i)) frame)
167     (assert frame)))
168    
169 heller 1.30 (defimplementation compute-backtrace (start end)
170 heller 1.1 (let ((end (or end most-positive-fixnum))
171     (backtrace '()))
172     (do ((frame (nth-frame start) (dbg::frame-next frame))
173     (i start))
174     ((or (not frame) (= i end)) (nreverse backtrace))
175     (when (interesting-frame-p frame)
176     (incf i)
177     (push frame backtrace)))))
178    
179 heller 1.30 (defimplementation print-frame (frame stream)
180     (cond ((dbg::call-frame-p frame)
181     (format stream "~A ~A"
182     (dbg::call-frame-function-name frame)
183     (dbg::call-frame-arglist frame)))
184     (t (princ frame stream))))
185 heller 1.1
186 lgorrie 1.17 (defimplementation frame-locals (n)
187 heller 1.29 (let ((frame (nth-frame n)))
188 heller 1.1 (if (dbg::call-frame-p frame)
189     (destructuring-bind (vars with)
190     (dbg::frame-locals-format-list frame #'list 75 0)
191     (declare (ignore with))
192 heller 1.21 (mapcar (lambda (var)
193     (destructuring-bind (name value symbol location) var
194     (declare (ignore name location))
195 mbaringer 1.28 (list :name symbol :id 0
196     :value value)))
197 heller 1.21 vars)))))
198 heller 1.1
199 lgorrie 1.17 (defimplementation frame-catch-tags (index)
200 heller 1.1 (declare (ignore index))
201     nil)
202    
203 lgorrie 1.17 (defimplementation frame-source-location-for-emacs (frame)
204 heller 1.1 (let ((frame (nth-frame frame)))
205     (if (dbg::call-frame-p frame)
206     (let ((func (dbg::call-frame-function-name frame)))
207     (if func
208 heller 1.30 (cadr (name-source-location func)))))))
209 heller 1.26
210     (defimplementation eval-in-frame (form frame-number)
211     (let ((frame (nth-frame frame-number)))
212     (dbg::dbg-eval form frame)))
213    
214     (defimplementation return-from-frame (frame-number form)
215     (let* ((frame (nth-frame frame-number))
216 heller 1.30 (return-frame (dbg::find-frame-for-return frame)))
217 heller 1.26 (dbg::dbg-return-from-call-frame frame form return-frame
218     dbg::*debugger-stack*)))
219    
220     (defimplementation restart-frame (frame-number)
221     (let ((frame (nth-frame frame-number)))
222     (dbg::restart-frame frame :same-args t)))
223 heller 1.1
224 heller 1.18 ;;; Definition finding
225    
226 heller 1.26 (defun name-source-location (name)
227     (first (name-source-locations name)))
228 heller 1.4
229 heller 1.26 (defun name-source-locations (name)
230     (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name)))
231 heller 1.1 (cond ((not locations)
232 heller 1.26 (list :error (format nil "Cannot find source for ~S" name)))
233 heller 1.1 (t
234 heller 1.4 (loop for (dspec location) in locations
235 heller 1.30 collect (list dspec (make-dspec-location dspec location)))))))
236 heller 1.1
237 heller 1.30 (defimplementation find-definitions (name)
238     (name-source-locations name))
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.25 ;; XXX handle all cases in dspec:*dspec-classes*
282 heller 1.24 (defun dspec-buffer-position (dspec)
283 heller 1.18 (etypecase dspec
284     (cons (ecase (car dspec)
285 heller 1.26 ((defun defmacro defgeneric defvar defstruct
286     method structure package)
287 heller 1.24 `(:function-name ,(symbol-name (cadr dspec))))
288 heller 1.18 ;; XXX this isn't quite right
289     (lw:top-level-form `(:source-path ,(cdr dspec) nil))))
290     (symbol `(:function-name ,(symbol-name dspec)))))
291    
292 heller 1.25 (defun emacs-buffer-location-p (location)
293     (and (consp location)
294     (eq (car location) :emacs-buffer)))
295    
296 heller 1.26 (defun make-dspec-location (dspec location)
297     (flet ((filename (pathname)
298 heller 1.4 (multiple-value-bind (truename condition)
299     (ignore-errors (truename pathname))
300     (cond (condition
301     (return-from make-dspec-location
302     (list :error (format nil "~A" condition))))
303     (t (namestring truename)))))
304     (function-name (dspec)
305     (etypecase dspec
306     (symbol (symbol-name dspec))
307 heller 1.18 (cons (string (dspec:dspec-primary-name dspec))))))
308 heller 1.26 (etypecase location
309     ((or pathname string)
310     (make-location `(:file ,(filename location))
311     (dspec-buffer-position dspec)))
312     ((member :listener)
313     `(:error ,(format nil "Function defined in listener: ~S" dspec)))
314     ((member :unknown)
315     `(:error ,(format nil "Function location unkown: ~S" dspec)))
316     ((satisfies emacs-buffer-location-p)
317     (destructuring-bind (_ buffer offset string) location
318     (declare (ignore _ offset string))
319     (make-location `(:buffer ,buffer)
320     (dspec-buffer-position dspec)))))))
321 heller 1.1
322 heller 1.26 (defun signal-error-data-base (database location)
323 heller 1.1 (map-error-database
324     database
325     (lambda (filename dspec condition)
326 heller 1.26 (declare (ignore filename))
327 heller 1.1 (signal-compiler-condition
328     (format nil "~A" condition)
329 heller 1.26 (make-dspec-location dspec location)
330 heller 1.1 condition))))
331    
332 heller 1.26 (defun signal-undefined-functions (htab filename)
333 heller 1.1 (maphash (lambda (unfun dspecs)
334     (dolist (dspec dspecs)
335     (signal-compiler-condition
336     (format nil "Undefined function ~A" unfun)
337 heller 1.26 (make-dspec-location dspec filename)
338 heller 1.1 nil)))
339     htab))
340 heller 1.2
341 heller 1.30 (defimplementation swank-compile-string (string &key buffer position)
342 heller 1.1 (assert buffer)
343     (assert position)
344 heller 1.30 (let* ((location (list :emacs-buffer buffer position string))
345 heller 1.26 (compiler::*error-database* '())
346     (tmpname (hcl:make-temp-file nil "lisp")))
347 heller 1.1 (with-compilation-unit ()
348 heller 1.26 (compile-from-temp-file
349     (with-standard-io-syntax
350     (format nil "~S~%~A" `(eval-when (:compile-toplevel)
351     (setq dspec::*location* (list ,@location)))
352     string))
353     tmpname)
354     (signal-error-data-base compiler::*error-database* location)
355     (signal-undefined-functions compiler::*unknown-functions* location))))
356 heller 1.1
357 heller 1.3 ;;; xref
358    
359 heller 1.31 (defmacro defxref (name function)
360     `(defimplementation ,name (name)
361     (xref-results (,function name))))
362    
363     (defxref who-calls hcl:who-calls)
364     (defxref who-references hcl:who-references)
365     (defxref who-binds hcl:who-binds)
366     (defxref who-sets hcl:who-sets)
367     (defxref list-callees hcl:calls-who)
368    
369     (defun xref-results (dspecs)
370     (loop for dspec in dspecs
371     nconc (loop for (dspec location) in
372     (dspec:dspec-definition-locations dspec)
373     collect (list dspec
374     (make-dspec-location dspec location)))))
375 heller 1.25 ;;; Inspector
376    
377     (defmethod inspected-parts (o)
378     (multiple-value-bind (names values _getter _setter type)
379     (lw:get-inspector-values o nil)
380     (declare (ignore _getter _setter))
381     (values (format nil "~A~% is a ~A" o type)
382     (mapcar (lambda (name value)
383     (cons (princ-to-string name) value))
384     names values))))
385    
386 heller 1.16 ;;; Multithreading
387    
388 heller 1.18 (defimplementation startup-multiprocessing ()
389 heller 1.16 (mp:initialize-multiprocessing))
390    
391 heller 1.18 (defimplementation spawn (fn &key name)
392 heller 1.16 (mp:process-run-function name () fn))
393    
394 heller 1.21 (defimplementation thread-name (thread)
395     (mp:process-name thread))
396 heller 1.16
397 heller 1.21 (defimplementation thread-status (thread)
398     (format nil "~A ~D"
399     (mp:process-whostate thread)
400     (mp:process-priority thread)))
401 heller 1.16
402 heller 1.18 (defimplementation make-lock (&key name)
403 heller 1.16 (mp:make-lock :name name))
404    
405 heller 1.18 (defimplementation call-with-lock-held (lock function)
406 heller 1.16 (mp:with-lock (lock) (funcall function)))
407 heller 1.20
408     (defimplementation current-thread ()
409     mp:*current-process*)
410 heller 1.21
411     (defimplementation all-threads ()
412     (mp:list-all-processes))
413 heller 1.20
414     (defimplementation interrupt-thread (thread fn)
415     (mp:process-interrupt thread fn))
416 heller 1.25
417     (defimplementation kill-thread (thread)
418     (mp:process-kill thread))
419 heller 1.27
420     (defimplementation thread-alive-p (thread)
421     (mp:process-alive-p thread))
422 heller 1.20
423     (defvar *mailbox-lock* (mp:make-lock))
424    
425     (defun mailbox (thread)
426     (mp:with-lock (*mailbox-lock*)
427     (or (getf (mp:process-plist thread) 'mailbox)
428     (setf (getf (mp:process-plist thread) 'mailbox)
429     (mp:make-mailbox)))))
430    
431     (defimplementation receive ()
432     (mp:mailbox-read (mailbox mp:*current-process*)))
433    
434     (defimplementation send (thread object)
435     (mp:mailbox-send (mailbox thread) object))
436 heller 1.3

  ViewVC Help
Powered by ViewVC 1.1.5