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

Contents of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.28 - (hide annotations)
Fri Mar 5 14:26:14 2004 UTC (10 years, 1 month ago) by mbaringer
Branch: MAIN
Changes since 1.27: +2 -3 lines
See ChangeLog entry 2004-03-05 Marco Baringer
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 heller 1.22 (defimplementation create-socket (host port)
38 heller 1.13 (multiple-value-bind (socket where errno)
39 heller 1.22 (comm::create-tcp-socket-for-service port :address host)
40 heller 1.13 (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 heller 1.23 (defimplementation lisp-implementation-type-name ()
81     "lispworks")
82    
83 lgorrie 1.17 (defimplementation arglist-string (fname)
84 heller 1.24 (format-arglist fname
85     (lambda (symbol)
86     (let ((arglist (lw:function-lambda-list symbol)))
87     (etypecase arglist
88     ((member :dont-know)
89     (error "<arglist-unavailable>"))
90     (cons arglist))))))
91 heller 1.1
92 lgorrie 1.17 (defimplementation macroexpand-all (form)
93 heller 1.1 (walker:walk-form form))
94    
95 lgorrie 1.17 (defimplementation describe-symbol-for-emacs (symbol)
96 heller 1.1 "Return a plist describing SYMBOL.
97     Return NIL if the symbol is unbound."
98     (let ((result '()))
99     (labels ((first-line (string)
100     (let ((pos (position #\newline string)))
101     (if (null pos) string (subseq string 0 pos))))
102     (doc (kind &optional (sym symbol))
103     (let ((string (documentation sym kind)))
104     (if string
105     (first-line string)
106     :not-documented)))
107     (maybe-push (property value)
108     (when value
109     (setf result (list* property value result)))))
110     (maybe-push
111     :variable (when (boundp symbol)
112     (doc 'variable)))
113     (maybe-push
114     :function (if (fboundp symbol)
115     (doc 'function)))
116     (maybe-push
117     :class (if (find-class symbol nil)
118     (doc 'class)))
119     (if result
120     (list* :designator (to-string symbol) result)))))
121    
122 lgorrie 1.17 (defimplementation describe-definition (symbol-name type)
123     (case type
124     ;; FIXME: This should cover all types returned by
125     ;; DESCRIBE-SYMBOL-FOR-EMACS.
126     (:function (describe-function symbol-name))))
127    
128     (defun describe-function (symbol-name)
129 heller 1.4 (with-output-to-string (*standard-output*)
130     (let ((sym (from-string symbol-name)))
131     (cond ((fboundp sym)
132     (format t "~%(~A~{ ~A~})~%~%~:[(not documented)~;~:*~A~]~%"
133     (string-downcase sym)
134     (mapcar #'string-upcase
135     (lispworks:function-lambda-list sym))
136     (documentation sym 'function))
137     (describe (symbol-function sym)))
138     (t (format t "~S is not fbound" sym))))))
139    
140 heller 1.1 #+(or)
141 lgorrie 1.17 (defimplementation describe-object ((sym symbol) *standard-output*)
142 heller 1.1 (format t "~A is a symbol in package ~A." sym (symbol-package sym))
143     (when (boundp sym)
144     (format t "~%~%Value: ~A" (symbol-value sym)))
145     (let ((doc (documentation sym 'variable)))
146     (when doc
147     (format t "~%~%Variable documentation:~%~A" doc)))
148     (when (fboundp sym)
149     (format t "~%~%(~A~{ ~A~})"
150     (string-downcase sym)
151     (mapcar #'string-upcase
152     (lispworks:function-lambda-list sym))))
153     (let ((doc (documentation sym 'function)))
154     (when doc (format t "~%~%~A~%" doc))))
155    
156     ;;; Debugging
157    
158     (defvar *sldb-restarts*)
159 heller 1.26 (defvar *sldb-top-frame*)
160 heller 1.1
161     (defslimefun sldb-abort ()
162     (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
163    
164 lgorrie 1.17 (defimplementation call-with-debugging-environment (fn)
165 heller 1.1 (dbg::with-debugger-stack ()
166 heller 1.26 (let ((*sldb-restarts* (compute-restarts *swank-debugger-condition*))
167     (*sldb-top-frame* (dbg::debugger-stack-current-frame
168     dbg::*debugger-stack*)))
169 heller 1.1 (funcall fn))))
170    
171     (defun format-restarts-for-emacs ()
172     (loop for restart in *sldb-restarts*
173     collect (list (princ-to-string (restart-name restart))
174     (princ-to-string restart))))
175    
176     (defun interesting-frame-p (frame)
177     (or (dbg::call-frame-p frame)
178 heller 1.19 ;;(dbg::catch-frame-p frame)
179     ))
180 heller 1.1
181     (defun nth-frame (index)
182 heller 1.26 (do ((frame *sldb-top-frame* (dbg::frame-next frame))
183 heller 1.1 (i index (if (interesting-frame-p frame) (1- i) i)))
184     ((and (interesting-frame-p frame) (zerop i)) frame)
185     (assert frame)))
186    
187     (defun compute-backtrace (start end)
188     (let ((end (or end most-positive-fixnum))
189     (backtrace '()))
190     (do ((frame (nth-frame start) (dbg::frame-next frame))
191     (i start))
192     ((or (not frame) (= i end)) (nreverse backtrace))
193     (when (interesting-frame-p frame)
194     (incf i)
195     (push frame backtrace)))))
196    
197 lgorrie 1.17 (defimplementation backtrace (start end)
198 heller 1.1 (flet ((format-frame (f i)
199 heller 1.10 (print-with-frame-label
200     i (lambda (s)
201     (cond ((dbg::call-frame-p f)
202     (format s "~A ~A"
203     (dbg::call-frame-function-name f)
204     (dbg::call-frame-arglist f)))
205     (t (princ f s)))))))
206 heller 1.1 (loop for i from start
207     for f in (compute-backtrace start end)
208     collect (list i (format-frame f i)))))
209    
210 lgorrie 1.17 (defimplementation debugger-info-for-emacs (start end)
211 heller 1.10 (list (debugger-condition-for-emacs)
212 heller 1.1 (format-restarts-for-emacs)
213 heller 1.10 (backtrace start end)))
214 heller 1.1
215     (defun nth-restart (index)
216     (nth index *sldb-restarts*))
217    
218     (defslimefun invoke-nth-restart (index)
219 heller 1.5 (invoke-restart-interactively (nth-restart index)))
220 heller 1.1
221 lgorrie 1.17 (defimplementation frame-locals (n)
222 heller 1.21 (let ((frame (nth-frame n))
223     (*print-readably* nil)
224     (*print-pretty* t)
225     (*print-circle* t))
226 heller 1.1 (if (dbg::call-frame-p frame)
227     (destructuring-bind (vars with)
228     (dbg::frame-locals-format-list frame #'list 75 0)
229     (declare (ignore with))
230 heller 1.21 (mapcar (lambda (var)
231     (destructuring-bind (name value symbol location) var
232     (declare (ignore name location))
233 mbaringer 1.28 (list :name symbol :id 0
234     :value value)))
235 heller 1.21 vars)))))
236 heller 1.1
237 lgorrie 1.17 (defimplementation frame-catch-tags (index)
238 heller 1.1 (declare (ignore index))
239     nil)
240    
241 lgorrie 1.17 (defimplementation frame-source-location-for-emacs (frame)
242 heller 1.1 (let ((frame (nth-frame frame)))
243     (if (dbg::call-frame-p frame)
244     (let ((func (dbg::call-frame-function-name frame)))
245     (if func
246 heller 1.26 (name-source-location func))))))
247    
248     (defimplementation eval-in-frame (form frame-number)
249     (let ((frame (nth-frame frame-number)))
250     (dbg::dbg-eval form frame)))
251    
252     (defimplementation return-from-frame (frame-number form)
253     (let* ((frame (nth-frame frame-number))
254     (return-frame (dbg::find-frame-for-return frame))
255     (form (from-string form)))
256     (dbg::dbg-return-from-call-frame frame form return-frame
257     dbg::*debugger-stack*)))
258    
259     (defimplementation restart-frame (frame-number)
260     (let ((frame (nth-frame frame-number)))
261     (dbg::restart-frame frame :same-args t)))
262 heller 1.1
263 heller 1.18 ;;; Definition finding
264    
265 heller 1.26 (defun name-source-location (name)
266     (first (name-source-locations name)))
267 heller 1.4
268 heller 1.26 (defun name-source-locations (name)
269     (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name)))
270 heller 1.1 (cond ((not locations)
271 heller 1.26 (list :error (format nil "Cannot find source for ~S" name)))
272 heller 1.1 (t
273 heller 1.4 (loop for (dspec location) in locations
274     collect (make-dspec-location dspec location))))))
275 heller 1.1
276 lgorrie 1.17 (defimplementation find-function-locations (fname)
277 heller 1.26 (name-source-locations (from-string fname)))
278 heller 1.6
279 heller 1.18 ;;; Compilation
280    
281 lgorrie 1.17 (defimplementation compile-file-for-emacs (filename load-p)
282 heller 1.1 (let ((compiler::*error-database* '()))
283     (with-compilation-unit ()
284     (compile-file filename :load load-p)
285 heller 1.26 (signal-error-data-base compiler::*error-database* filename)
286 heller 1.1 (signal-undefined-functions compiler::*unknown-functions* filename))))
287    
288     (defun map-error-database (database fn)
289     (loop for (filename . defs) in database do
290     (loop for (dspec . conditions) in defs do
291     (dolist (c conditions)
292     (funcall fn filename dspec c)))))
293    
294     (defun lispworks-severity (condition)
295     (cond ((not condition) :warning)
296     (t (etypecase condition
297 heller 1.6 (error :error)
298 heller 1.1 (style-warning :warning)
299     (warning :warning)))))
300    
301     (defun signal-compiler-condition (message location condition)
302     (check-type message string)
303     (signal
304     (make-instance 'compiler-condition :message message
305     :severity (lispworks-severity condition)
306     :location location
307     :original-condition condition)))
308    
309     (defun compile-from-temp-file (string filename)
310     (unwind-protect
311     (progn
312     (with-open-file (s filename :direction :output :if-exists :supersede)
313     (write-string string s)
314     (finish-output s))
315     (let ((binary-filename (compile-file filename :load t)))
316 heller 1.6 (when binary-filename
317     (delete-file binary-filename))))
318 heller 1.1 (delete-file filename)))
319    
320 heller 1.25 ;; XXX handle all cases in dspec:*dspec-classes*
321 heller 1.24 (defun dspec-buffer-position (dspec)
322 heller 1.18 (etypecase dspec
323     (cons (ecase (car dspec)
324 heller 1.26 ((defun defmacro defgeneric defvar defstruct
325     method structure package)
326 heller 1.24 `(:function-name ,(symbol-name (cadr dspec))))
327 heller 1.18 ;; XXX this isn't quite right
328     (lw:top-level-form `(:source-path ,(cdr dspec) nil))))
329     (symbol `(:function-name ,(symbol-name dspec)))))
330    
331 heller 1.25 (defun emacs-buffer-location-p (location)
332     (and (consp location)
333     (eq (car location) :emacs-buffer)))
334    
335 heller 1.26 (defun make-dspec-location (dspec location)
336     (flet ((filename (pathname)
337 heller 1.4 (multiple-value-bind (truename condition)
338     (ignore-errors (truename pathname))
339     (cond (condition
340     (return-from make-dspec-location
341     (list :error (format nil "~A" condition))))
342     (t (namestring truename)))))
343     (function-name (dspec)
344     (etypecase dspec
345     (symbol (symbol-name dspec))
346 heller 1.18 (cons (string (dspec:dspec-primary-name dspec))))))
347 heller 1.26 (etypecase location
348     ((or pathname string)
349     (make-location `(:file ,(filename location))
350     (dspec-buffer-position dspec)))
351     ((member :listener)
352     `(:error ,(format nil "Function defined in listener: ~S" dspec)))
353     ((member :unknown)
354     `(:error ,(format nil "Function location unkown: ~S" dspec)))
355     ((satisfies emacs-buffer-location-p)
356     (destructuring-bind (_ buffer offset string) location
357     (declare (ignore _ offset string))
358     (make-location `(:buffer ,buffer)
359     (dspec-buffer-position dspec)))))))
360 heller 1.1
361 heller 1.26 (defun signal-error-data-base (database location)
362 heller 1.1 (map-error-database
363     database
364     (lambda (filename dspec condition)
365 heller 1.26 (declare (ignore filename))
366 heller 1.1 (signal-compiler-condition
367     (format nil "~A" condition)
368 heller 1.26 (make-dspec-location dspec location)
369 heller 1.1 condition))))
370    
371 heller 1.26 (defun signal-undefined-functions (htab filename)
372 heller 1.1 (maphash (lambda (unfun dspecs)
373     (dolist (dspec dspecs)
374     (signal-compiler-condition
375     (format nil "Undefined function ~A" unfun)
376 heller 1.26 (make-dspec-location dspec filename)
377 heller 1.1 nil)))
378     htab))
379 heller 1.2
380 lgorrie 1.17 (defimplementation compile-string-for-emacs (string &key buffer position)
381 heller 1.1 (assert buffer)
382     (assert position)
383 heller 1.26 (let* ((*package* *buffer-package*)
384     (location (list :emacs-buffer buffer position string))
385     (compiler::*error-database* '())
386     (tmpname (hcl:make-temp-file nil "lisp")))
387 heller 1.1 (with-compilation-unit ()
388 heller 1.26 (compile-from-temp-file
389     (with-standard-io-syntax
390     (format nil "~S~%~A" `(eval-when (:compile-toplevel)
391     (setq dspec::*location* (list ,@location)))
392     string))
393     tmpname)
394     (signal-error-data-base compiler::*error-database* location)
395     (signal-undefined-functions compiler::*unknown-functions* location))))
396 heller 1.1
397 heller 1.3 ;;; xref
398    
399 heller 1.4 (defun lookup-xrefs (finder name)
400     (xref-results-for-emacs (funcall finder (from-string name))))
401    
402 lgorrie 1.17 (defimplementation who-calls (function-name)
403 heller 1.4 (lookup-xrefs #'hcl:who-calls function-name))
404 heller 1.3
405 lgorrie 1.17 (defimplementation who-references (variable)
406 heller 1.4 (lookup-xrefs #'hcl:who-references variable))
407 heller 1.3
408 lgorrie 1.17 (defimplementation who-binds (variable)
409 heller 1.4 (lookup-xrefs #'hcl:who-binds variable))
410 heller 1.3
411 lgorrie 1.17 (defimplementation who-sets (variable)
412 heller 1.4 (lookup-xrefs #'hcl:who-sets variable))
413 heller 1.3
414     (defun xref-results-for-emacs (dspecs)
415     (let ((xrefs '()))
416     (dolist (dspec dspecs)
417     (loop for (dspec location) in (dspec:find-dspec-locations dspec)
418     do (push (cons (to-string dspec)
419     (make-dspec-location dspec location))
420     xrefs)))
421     (group-xrefs xrefs)))
422 heller 1.4
423 lgorrie 1.17 (defimplementation list-callers (symbol-name)
424 heller 1.4 (lookup-xrefs #'hcl:who-calls symbol-name))
425    
426 lgorrie 1.17 (defimplementation list-callees (symbol-name)
427 heller 1.4 (lookup-xrefs #'hcl:calls-who symbol-name))
428 heller 1.3
429 heller 1.25 ;;; Inspector
430    
431     (defmethod inspected-parts (o)
432     (multiple-value-bind (names values _getter _setter type)
433     (lw:get-inspector-values o nil)
434     (declare (ignore _getter _setter))
435     (values (format nil "~A~% is a ~A" o type)
436     (mapcar (lambda (name value)
437     (cons (princ-to-string name) value))
438     names values))))
439    
440 heller 1.16 ;;; Multithreading
441    
442 heller 1.18 (defimplementation startup-multiprocessing ()
443 heller 1.16 (mp:initialize-multiprocessing))
444    
445 heller 1.18 (defimplementation spawn (fn &key name)
446 heller 1.16 (mp:process-run-function name () fn))
447    
448 heller 1.21 (defimplementation thread-name (thread)
449     (mp:process-name thread))
450 heller 1.16
451 heller 1.21 (defimplementation thread-status (thread)
452     (format nil "~A ~D"
453     (mp:process-whostate thread)
454     (mp:process-priority thread)))
455 heller 1.16
456 heller 1.18 (defimplementation make-lock (&key name)
457 heller 1.16 (mp:make-lock :name name))
458    
459 heller 1.18 (defimplementation call-with-lock-held (lock function)
460 heller 1.16 (mp:with-lock (lock) (funcall function)))
461 heller 1.20
462     (defimplementation current-thread ()
463     mp:*current-process*)
464 heller 1.21
465     (defimplementation all-threads ()
466     (mp:list-all-processes))
467 heller 1.20
468     (defimplementation interrupt-thread (thread fn)
469     (mp:process-interrupt thread fn))
470 heller 1.25
471     (defimplementation kill-thread (thread)
472     (mp:process-kill thread))
473 heller 1.27
474     (defimplementation thread-alive-p (thread)
475     (mp:process-alive-p thread))
476 heller 1.20
477     (defvar *mailbox-lock* (mp:make-lock))
478    
479     (defun mailbox (thread)
480     (mp:with-lock (*mailbox-lock*)
481     (or (getf (mp:process-plist thread) 'mailbox)
482     (setf (getf (mp:process-plist thread) 'mailbox)
483     (mp:make-mailbox)))))
484    
485     (defimplementation receive ()
486     (mp:mailbox-read (mailbox mp:*current-process*)))
487    
488     (defimplementation send (thread object)
489     (mp:mailbox-send (mailbox thread) object))
490 heller 1.3

  ViewVC Help
Powered by ViewVC 1.1.5