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

Contents of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.55 - (show annotations)
Fri Sep 3 21:10:13 2004 UTC (9 years, 7 months ago) by heller
Branch: MAIN
CVS Tags: SLIME-1-0
Changes since 1.54: +2 -2 lines
(defimplementation): define-dspec-alias seems to more apropriate than
define-form-parser.
1 ;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 ;;;
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-backend)
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 (when (fboundp 'dspec::define-dspec-alias)
29 (dspec::define-dspec-alias defimplementation (name args &rest body)
30 `(defmethod ,name ,args ,@body)))
31
32 ;;; TCP server
33
34 (defimplementation preferred-communication-style ()
35 :spawn)
36
37 (defun socket-fd (socket)
38 (etypecase socket
39 (fixnum socket)
40 (comm:socket-stream (comm:socket-stream-socket socket))))
41
42 (defimplementation create-socket (host port)
43 (multiple-value-bind (socket where errno)
44 #-lispworks4.1(comm::create-tcp-socket-for-service port :address host)
45 #+lispworks4.1(comm::create-tcp-socket-for-service port)
46 (cond (socket socket)
47 (t (error 'network-error
48 :format-control "~A failed: ~A (~D)"
49 :format-arguments (list where
50 (list #+unix (lw:get-unix-error errno))
51 errno))))))
52
53 (defimplementation local-port (socket)
54 (nth-value 1 (comm:get-socket-address (socket-fd socket))))
55
56 (defimplementation close-socket (socket)
57 (comm::close-socket (socket-fd socket)))
58
59 (defimplementation accept-connection (socket)
60 (let ((fd (comm::get-fd-from-socket socket)))
61 (assert (/= fd -1))
62 (make-instance 'comm:socket-stream :socket fd :direction :io
63 :element-type 'base-char)))
64
65 (defun set-sigint-handler ()
66 ;; Set SIGINT handler on Swank request handler thread.
67 #-win32
68 (sys::set-signal-handler +sigint+
69 (make-sigint-handler mp:*current-process*)))
70
71 (defimplementation emacs-connected (stream)
72 (declare (ignore stream))
73 (set-sigint-handler)
74 (let ((lw:*handle-warn-on-redefinition* :warn))
75 (defmethod stream:stream-soft-force-output ((o comm:socket-stream))
76 (force-output o))
77 (defmethod stream:stream-soft-force-output ((o slime-output-stream))
78 (force-output o))
79 (defmethod env-internals:environment-display-notifier
80 (env &key restarts condition)
81 (declare (ignore restarts))
82 (funcall (find-symbol (string :swank-debugger-hook) :swank)
83 condition *debugger-hook*))
84 (defmethod env-internals:environment-display-debugger
85 (env)
86 *debug-io*)))
87
88 ;;; Unix signals
89
90 (defun sigint-handler ()
91 (with-simple-restart (continue "Continue from SIGINT handler.")
92 (invoke-debugger "SIGINT")))
93
94 (defun make-sigint-handler (process)
95 (lambda (&rest args)
96 (declare (ignore args))
97 (mp:process-interrupt process #'sigint-handler)))
98
99 (defimplementation call-without-interrupts (fn)
100 (lw:without-interrupts (funcall fn)))
101
102 (defimplementation getpid ()
103 #+win32 (win32:get-current-process-id)
104 #-win32 (system::getpid))
105
106 (defimplementation lisp-implementation-type-name ()
107 "lispworks")
108
109 (defimplementation set-default-directory (directory)
110 (namestring (hcl:change-directory directory)))
111
112 ;;;; Documentation
113
114 (defimplementation arglist (symbol)
115 (let ((arglist (lw:function-lambda-list symbol)))
116 (etypecase arglist
117 ((member :dont-know)
118 :not-available)
119 (list
120 arglist))))
121
122 (defimplementation macroexpand-all (form)
123 (walker:walk-form form))
124
125 (defun generic-function-p (object)
126 (typep object 'generic-function))
127
128 (defimplementation describe-symbol-for-emacs (symbol)
129 "Return a plist describing SYMBOL.
130 Return NIL if the symbol is unbound."
131 (let ((result '()))
132 (labels ((first-line (string)
133 (let ((pos (position #\newline string)))
134 (if (null pos) string (subseq string 0 pos))))
135 (doc (kind &optional (sym symbol))
136 (let ((string (documentation sym kind)))
137 (if string
138 (first-line string)
139 :not-documented)))
140 (maybe-push (property value)
141 (when value
142 (setf result (list* property value result)))))
143 (maybe-push
144 :variable (when (boundp symbol)
145 (doc 'variable)))
146 (maybe-push
147 :generic-function (if (and (fboundp symbol)
148 (generic-function-p (fdefinition symbol)))
149 (doc 'function)))
150 (maybe-push
151 :function (if (and (fboundp symbol)
152 (not (generic-function-p (fdefinition symbol))))
153 (doc 'function)))
154 (maybe-push
155 :setf (let ((setf-name (sys:underlying-setf-name `(setf ,symbol))))
156 (if (fboundp setf-name)
157 (doc 'setf))))
158 (maybe-push
159 :class (if (find-class symbol nil)
160 (doc 'class)))
161 result)))
162
163 (defimplementation describe-definition (symbol type)
164 (ecase type
165 (:variable (describe-symbol symbol))
166 (:class (describe (find-class symbol)))
167 ((:function :generic-function) (describe-function symbol))
168 (:setf (describe-function (sys:underlying-setf-name `(setf ,symbol))))))
169
170 (defun describe-function (symbol)
171 (cond ((fboundp symbol)
172 (format t "~%(~A~{ ~A~})~%~%~:[(not documented)~;~:*~A~]~%"
173 (string-downcase symbol)
174 (mapcar #'string-upcase
175 (lispworks:function-lambda-list symbol))
176 (documentation symbol 'function))
177 (describe (fdefinition symbol)))
178 (t (format t "~S is not fbound" symbol))))
179
180 (defun describe-symbol (sym)
181 (format t "~A is a symbol in package ~A." sym (symbol-package sym))
182 (when (boundp sym)
183 (format t "~%~%Value: ~A" (symbol-value sym)))
184 (let ((doc (documentation sym 'variable)))
185 (when doc
186 (format t "~%~%Variable documentation:~%~A" doc)))
187 (when (fboundp sym)
188 (describe-function sym)))
189
190 ;;; Debugging
191
192 (defvar *sldb-top-frame*)
193
194 (defun interesting-frame-p (frame)
195 (cond ((or (dbg::call-frame-p frame)
196 (dbg::derived-call-frame-p frame)
197 (dbg::foreign-frame-p frame)
198 (dbg::interpreted-call-frame-p frame))
199 t)
200 ((dbg::catch-frame-p frame) dbg:*print-catch-frames*)
201 ((dbg::binding-frame-p frame) dbg:*print-binding-frames*)
202 ((dbg::handler-frame-p frame) dbg:*print-handler-frames*)
203 ((dbg::restart-frame-p frame) dbg:*print-restart-frames*)
204 ((dbg::open-frame-p frame) dbg:*print-open-frames*)
205 (t nil)))
206
207 (defun nth-next-frame (frame n)
208 "Unwind FRAME N times."
209 (do ((frame frame (dbg::frame-next frame))
210 (i n (if (interesting-frame-p frame) (1- i) i)))
211 ((or (not frame)
212 (and (interesting-frame-p frame) (zerop i)))
213 frame)))
214
215 (defun nth-frame (index)
216 (nth-next-frame *sldb-top-frame* index))
217
218 (defun find-top-frame ()
219 "Return the most suitable top-frame for the debugger."
220 (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*)
221 (nth-next-frame frame 1)))
222 ((and (dbg::call-frame-p frame)
223 (eq (dbg::call-frame-function-name frame)
224 'invoke-debugger))
225 (nth-next-frame frame 1))))
226
227 (defimplementation call-with-debugging-environment (fn)
228 (dbg::with-debugger-stack ()
229 (let ((*sldb-top-frame* (find-top-frame)))
230 (funcall fn))))
231
232 (defimplementation compute-backtrace (start end)
233 (let ((end (or end most-positive-fixnum))
234 (backtrace '()))
235 (do ((frame (nth-frame start) (dbg::frame-next frame))
236 (i start))
237 ((or (not frame) (= i end)) (nreverse backtrace))
238 (when (interesting-frame-p frame)
239 (incf i)
240 (push frame backtrace)))))
241
242 (defun frame-actual-args (frame)
243 (let ((*break-on-signals* nil))
244 (mapcar (lambda (arg)
245 (case arg
246 ((&rest &optional &key) arg)
247 (t
248 (handler-case (dbg::dbg-eval arg frame)
249 (error (e) (format nil "<~A>" arg))))))
250 (dbg::call-frame-arglist frame))))
251
252 (defimplementation print-frame (frame stream)
253 (cond ((dbg::call-frame-p frame)
254 (format stream "~S ~S"
255 (dbg::call-frame-function-name frame)
256 (frame-actual-args frame)))
257 (t (princ frame stream))))
258
259 (defun frame-vars (frame)
260 (first (dbg::frame-locals-format-list frame #'list 75 0)))
261
262 (defimplementation frame-locals (n)
263 (let ((frame (nth-frame n)))
264 (if (dbg::call-frame-p frame)
265 (mapcar (lambda (var)
266 (destructuring-bind (name value symbol location) var
267 (declare (ignore name location))
268 (list :name symbol :id 0
269 :value value)))
270 (frame-vars frame)))))
271
272 (defimplementation frame-var-value (frame var)
273 (let ((frame (nth-frame frame)))
274 (destructuring-bind (_n value _s _l) (nth var (frame-vars frame))
275 (declare (ignore _n _s _l))
276 value)))
277
278 (defimplementation frame-catch-tags (index)
279 (declare (ignore index))
280 nil)
281
282 (defimplementation frame-source-location-for-emacs (frame)
283 (let ((frame (nth-frame frame)))
284 (if (dbg::call-frame-p frame)
285 (let ((name (dbg::call-frame-function-name frame)))
286 (if name
287 (function-name-location name))))))
288
289 (defimplementation eval-in-frame (form frame-number)
290 (let ((frame (nth-frame frame-number)))
291 (dbg::dbg-eval form frame)))
292
293 (defimplementation return-from-frame (frame-number form)
294 (let* ((frame (nth-frame frame-number))
295 (return-frame (dbg::find-frame-for-return frame)))
296 (dbg::dbg-return-from-call-frame frame form return-frame
297 dbg::*debugger-stack*)))
298
299 (defimplementation restart-frame (frame-number)
300 (let ((frame (nth-frame frame-number)))
301 (dbg::restart-frame frame :same-args t)))
302
303 ;;; Definition finding
304
305 (defun function-name-location (name)
306 (let ((defs (find-definitions name)))
307 (cond (defs (cadr (first defs)))
308 (t (list :error (format nil "Source location not available for: ~S"
309 name))))))
310
311 (defimplementation find-definitions (name)
312 (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name)))
313 (loop for (dspec location) in locations
314 collect (list dspec (make-dspec-location dspec location)))))
315
316 ;;; Compilation
317
318 (defmacro with-swank-compilation-unit ((location &rest options) &body body)
319 (lw:rebinding (location)
320 `(let ((compiler::*error-database* '()))
321 (with-compilation-unit ,options
322 ,@body
323 (signal-error-data-base compiler::*error-database* ,location)
324 (signal-undefined-functions compiler::*unknown-functions* ,location)))))
325
326 (defimplementation swank-compile-file (filename load-p)
327 (with-swank-compilation-unit (filename)
328 (compile-file filename :load load-p)))
329
330 (defun map-error-database (database fn)
331 (loop for (filename . defs) in database do
332 (loop for (dspec . conditions) in defs do
333 (dolist (c conditions)
334 (funcall fn filename dspec c)))))
335
336 (defun lispworks-severity (condition)
337 (cond ((not condition) :warning)
338 (t (etypecase condition
339 (error :error)
340 (style-warning :warning)
341 (warning :warning)))))
342
343 (defun signal-compiler-condition (message location condition)
344 (check-type message string)
345 (signal
346 (make-instance 'compiler-condition :message message
347 :severity (lispworks-severity condition)
348 :location location
349 :original-condition condition)))
350
351 (defun compile-from-temp-file (string filename)
352 (unwind-protect
353 (progn
354 (with-open-file (s filename :direction :output :if-exists :supersede)
355 (write-string string s)
356 (finish-output s))
357 (let ((binary-filename (compile-file filename :load t)))
358 (when binary-filename
359 (delete-file binary-filename))))
360 (delete-file filename)))
361
362 (defun dspec-buffer-position (dspec offset)
363 (etypecase dspec
364 (cons (let ((name (dspec:dspec-primary-name dspec)))
365 (typecase name
366 ((or symbol string)
367 (list :function-name (string name)))
368 (t (list :position offset)))))
369 (null (list :position offset))
370 (symbol (list :function-name (string dspec)))))
371
372 (defmacro with-fairly-standard-io-syntax (&body body)
373 "Like WITH-STANDARD-IO-SYNTAX but preserve *PACKAGE* and *READTABLE*."
374 (let ((package (gensym))
375 (readtable (gensym)))
376 `(let ((,package *package*)
377 (,readtable *readtable*))
378 (with-standard-io-syntax
379 (let ((*package* ,package)
380 (*readtable* ,readtable))
381 ,@body)))))
382
383 #-(or lispworks4.1 lispworks4.2) ; no dspec:parse-form-dspec prior to 4.3
384 (defun dspec-stream-position (stream dspec)
385 (with-fairly-standard-io-syntax
386 (loop (let* ((pos (file-position stream))
387 (form (read stream nil '#1=#:eof)))
388 (when (eq form '#1#)
389 (return nil))
390 (labels ((check-dspec (form)
391 (when (consp form)
392 (let ((operator (car form)))
393 (case operator
394 ((progn)
395 (mapcar #'check-dspec
396 (cdr form)))
397 ((eval-when locally macrolet symbol-macrolet)
398 (mapcar #'check-dspec
399 (cddr form)))
400 ((in-package)
401 (let ((package (find-package (second form))))
402 (when package
403 (setq *package* package))))
404 (otherwise
405 (let ((form-dspec (dspec:parse-form-dspec form)))
406 (when (dspec:dspec-equal dspec form-dspec)
407 (return pos)))))))))
408 (check-dspec form))))))
409
410 (defun dspec-file-position (file dspec)
411 (with-open-file (stream file)
412 (let ((pos
413 #-(or lispworks4.1 lispworks4.2)
414 (dspec-stream-position stream dspec)))
415 (if pos
416 (list :position (1+ pos) t)
417 (dspec-buffer-position dspec 1)))))
418
419 (defun emacs-buffer-location-p (location)
420 (and (consp location)
421 (eq (car location) :emacs-buffer)))
422
423 (defun make-dspec-location (dspec location)
424 (etypecase location
425 ((or pathname string)
426 (multiple-value-bind (file err)
427 (ignore-errors (namestring (truename location)))
428 (if err
429 (list :error (princ-to-string err))
430 (make-location `(:file ,file)
431 (dspec-file-position file dspec)))))
432 (symbol
433 `(:error ,(format nil "Cannot resolve location: ~S" location)))
434 ((satisfies emacs-buffer-location-p)
435 (destructuring-bind (_ buffer offset string) location
436 (declare (ignore _ string))
437 (make-location `(:buffer ,buffer)
438 (dspec-buffer-position dspec offset))))))
439
440 (defun make-dspec-progenitor-location (dspec location)
441 (let ((canon-dspec (dspec:canonicalize-dspec dspec)))
442 (make-dspec-location
443 (if canon-dspec
444 (if (dspec:local-dspec-p canon-dspec)
445 (dspec:dspec-progenitor canon-dspec)
446 canon-dspec)
447 nil)
448 location)))
449
450 (defun signal-error-data-base (database location)
451 (map-error-database
452 database
453 (lambda (filename dspec condition)
454 (declare (ignore filename))
455 (signal-compiler-condition
456 (format nil "~A" condition)
457 (make-dspec-progenitor-location dspec location)
458 condition))))
459
460 (defun signal-undefined-functions (htab filename)
461 (maphash (lambda (unfun dspecs)
462 (dolist (dspec dspecs)
463 (signal-compiler-condition
464 (format nil "Undefined function ~A" unfun)
465 (make-dspec-progenitor-location dspec filename)
466 nil)))
467 htab))
468
469 (defimplementation swank-compile-string (string &key buffer position directory)
470 (declare (ignore directory))
471 (assert buffer)
472 (assert position)
473 (let* ((location (list :emacs-buffer buffer position string))
474 (tmpname (hcl:make-temp-file nil "lisp")))
475 (with-swank-compilation-unit (location)
476 (compile-from-temp-file
477 (format nil "~S~%~A" `(eval-when (:compile-toplevel)
478 (setq dspec::*location* (list ,@location)))
479 string)
480 tmpname))))
481
482 ;;; xref
483
484 (defmacro defxref (name function)
485 `(defimplementation ,name (name)
486 (xref-results (,function name))))
487
488 (defxref who-calls hcl:who-calls)
489 (defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too
490 (defxref list-callees hcl:calls-who)
491 (defxref list-callers list-callers-internal)
492
493 (defun list-callers-internal (name)
494 (let ((callers (make-array 100
495 :fill-pointer 0
496 :adjustable t)))
497 (hcl:sweep-all-objects
498 #'(lambda (object)
499 (when (and #+Harlequin-PC-Lisp (low:compiled-code-p object)
500 #-Harlequin-PC-Lisp (sys::callablep object)
501 (system::find-constant$funcallable name object))
502 (vector-push-extend object callers))))
503 ;; Delay dspec:object-dspec until after sweep-all-objects
504 ;; to reduce allocation problems.
505 (loop for object across callers
506 collect (if (symbolp object)
507 (list 'function object)
508 (dspec:object-dspec object)))))
509
510 ;; only for lispworks 4.2 and above
511 #-lispworks4.1
512 (progn
513 (defxref who-references hcl:who-references)
514 (defxref who-binds hcl:who-binds)
515 (defxref who-sets hcl:who-sets))
516
517 (defimplementation who-specializes (classname)
518 (let ((methods (clos:class-direct-methods (find-class classname))))
519 (xref-results (mapcar #'dspec:object-dspec methods))))
520
521 (defun xref-results (dspecs)
522 (loop for dspec in dspecs
523 nconc (loop for (dspec location)
524 in (dspec:dspec-definition-locations dspec)
525 collect (list dspec
526 (make-dspec-location dspec location)))))
527 ;;; Inspector
528
529 (defmethod inspected-parts (o)
530 (multiple-value-bind (names values _getter _setter type)
531 (lw:get-inspector-values o nil)
532 (declare (ignore _getter _setter))
533 (values (format nil "~A~% is a ~A" o type)
534 (mapcar #'cons names values))))
535
536 ;;; Miscellaneous
537
538 (defimplementation quit-lisp ()
539 (lispworks:quit))
540
541 ;;; Multithreading
542
543 (defimplementation startup-multiprocessing ()
544 (mp:initialize-multiprocessing))
545
546 (defimplementation spawn (fn &key name)
547 (let ((mp:*process-initial-bindings*
548 (remove (find-package :cl)
549 mp:*process-initial-bindings*
550 :key (lambda (x) (symbol-package (car x))))))
551 (mp:process-run-function name () fn)))
552
553 (defvar *id-lock* (mp:make-lock))
554 (defvar *thread-id-counter* 0)
555
556 (defimplementation thread-id (thread)
557 (mp:with-lock (*id-lock*)
558 (or (getf (mp:process-plist thread) 'id)
559 (setf (getf (mp:process-plist thread) 'id)
560 (incf *thread-id-counter*)))))
561
562 (defimplementation find-thread (id)
563 (find id (mp:list-all-processes)
564 :key (lambda (p) (getf (mp:process-plist p) 'id))))
565
566 (defimplementation thread-name (thread)
567 (mp:process-name thread))
568
569 (defimplementation thread-status (thread)
570 (format nil "~A ~D"
571 (mp:process-whostate thread)
572 (mp:process-priority thread)))
573
574 (defimplementation make-lock (&key name)
575 (mp:make-lock :name name))
576
577 (defimplementation call-with-lock-held (lock function)
578 (mp:with-lock (lock) (funcall function)))
579
580 (defimplementation current-thread ()
581 mp:*current-process*)
582
583 (defimplementation all-threads ()
584 (mp:list-all-processes))
585
586 (defimplementation interrupt-thread (thread fn)
587 (mp:process-interrupt thread fn))
588
589 (defimplementation kill-thread (thread)
590 (mp:process-kill thread))
591
592 (defimplementation thread-alive-p (thread)
593 (mp:process-alive-p thread))
594
595 (defvar *mailbox-lock* (mp:make-lock))
596
597 (defun mailbox (thread)
598 (mp:with-lock (*mailbox-lock*)
599 (or (getf (mp:process-plist thread) 'mailbox)
600 (setf (getf (mp:process-plist thread) 'mailbox)
601 (mp:make-mailbox)))))
602
603 (defimplementation receive ()
604 (mp:mailbox-read (mailbox mp:*current-process*)))
605
606 (defimplementation send (thread object)
607 (mp:mailbox-send (mailbox thread) object))
608

  ViewVC Help
Powered by ViewVC 1.1.5