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

Contents of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5