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

Contents of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5