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

Contents of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.129 - (show annotations)
Thu Jan 15 17:07:21 2009 UTC (5 years, 3 months ago) by msimmons
Branch: MAIN
Changes since 1.128: +20 -0 lines
swank-lispworks.lisp: wrapper functions for swank-mop
slot-boundp-using-class, slot-value-using-class and
slot-makunbound-using-class to account for MOP differences.
1 ;;; -*- 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 (import-from :stream *gray-stream-symbols* :swank-backend))
16
17 (import-swank-mop-symbols :clos '(:slot-definition-documentation
18 :slot-boundp-using-class
19 :slot-value-using-class
20 :slot-makunbound-using-class
21 :eql-specializer
22 :eql-specializer-object
23 :compute-applicable-methods-using-classes))
24
25 (defun swank-mop:slot-definition-documentation (slot)
26 (documentation slot t))
27
28 (defun swank-mop:slot-boundp-using-class (class object slotd)
29 (clos:slot-boundp-using-class class object
30 (clos:slot-definition-name slotd)))
31
32 (defun swank-mop:slot-value-using-class (class object slotd)
33 (clos:slot-value-using-class class object
34 (clos:slot-definition-name slotd)))
35
36 (defun (setf swank-mop:slot-value-using-class) (value class object slotd)
37 (setf (clos:slot-value-using-class class object
38 (clos:slot-definition-name slotd))
39 value))
40
41 (defun swank-mop:slot-makunbound-using-class (class object slotd)
42 (clos:slot-makunbound-using-class class object
43 (clos:slot-definition-name slotd)))
44
45 (defun swank-mop:compute-applicable-methods-using-classes (gf classes)
46 (clos::compute-applicable-methods-from-classes gf classes))
47
48 ;; lispworks doesn't have the eql-specializer class, it represents
49 ;; them as a list of `(EQL ,OBJECT)
50 (deftype swank-mop:eql-specializer () 'cons)
51
52 (defun swank-mop:eql-specializer-object (eql-spec)
53 (second eql-spec))
54
55 (eval-when (:compile-toplevel :execute :load-toplevel)
56 (defvar *original-defimplementation* (macro-function 'defimplementation))
57 (defmacro defimplementation (&whole whole name args &body body
58 &environment env)
59 (declare (ignore args body))
60 `(progn
61 (dspec:record-definition '(defun ,name) (dspec:location)
62 :check-redefinition-p nil)
63 ,(funcall *original-defimplementation* whole env))))
64
65 ;;; TCP server
66
67 (defimplementation preferred-communication-style ()
68 :spawn)
69
70 (defun socket-fd (socket)
71 (etypecase socket
72 (fixnum socket)
73 (comm:socket-stream (comm:socket-stream-socket socket))))
74
75 (defimplementation create-socket (host port)
76 (multiple-value-bind (socket where errno)
77 #-(or lispworks4.1 (and macosx lispworks4.3))
78 (comm::create-tcp-socket-for-service port :address host)
79 #+(or lispworks4.1 (and macosx lispworks4.3))
80 (comm::create-tcp-socket-for-service port)
81 (cond (socket socket)
82 (t (error 'network-error
83 :format-control "~A failed: ~A (~D)"
84 :format-arguments (list where
85 (list #+unix (lw:get-unix-error errno))
86 errno))))))
87
88 (defimplementation local-port (socket)
89 (nth-value 1 (comm:get-socket-address (socket-fd socket))))
90
91 (defimplementation close-socket (socket)
92 (comm::close-socket (socket-fd socket)))
93
94 (defimplementation accept-connection (socket
95 &key external-format buffering timeout)
96 (declare (ignore buffering))
97 (let* ((fd (comm::get-fd-from-socket socket)))
98 (assert (/= fd -1))
99 (assert (valid-external-format-p external-format))
100 (cond ((member (first external-format) '(:latin-1 :ascii))
101 (make-instance 'comm:socket-stream
102 :socket fd
103 :direction :io
104 :read-timeout timeout
105 :element-type 'base-char))
106 (t
107 (make-flexi-stream
108 (make-instance 'comm:socket-stream
109 :socket fd
110 :direction :io
111 :read-timeout timeout
112 :element-type '(unsigned-byte 8))
113 external-format)))))
114
115 (defun make-flexi-stream (stream external-format)
116 (unless (member :flexi-streams *features*)
117 (error "Cannot use external format ~A without having installed flexi-streams in the inferior-lisp."
118 external-format))
119 (funcall (read-from-string "FLEXI-STREAMS:MAKE-FLEXI-STREAM")
120 stream
121 :external-format
122 (apply (read-from-string "FLEXI-STREAMS:MAKE-EXTERNAL-FORMAT")
123 external-format)))
124
125 ;;; Coding Systems
126
127 (defun valid-external-format-p (external-format)
128 (member external-format *external-format-to-coding-system*
129 :test #'equal :key #'car))
130
131 (defvar *external-format-to-coding-system*
132 '(((:latin-1 :eol-style :lf)
133 "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
134 ((:latin-1)
135 "latin-1" "iso-latin-1" "iso-8859-1")
136 ((:utf-8) "utf-8")
137 ((:utf-8 :eol-style :lf) "utf-8-unix")
138 ((:euc-jp) "euc-jp")
139 ((:euc-jp :eol-style :lf) "euc-jp-unix")
140 ((:ascii) "us-ascii")
141 ((:ascii :eol-style :lf) "us-ascii-unix")))
142
143 (defimplementation find-external-format (coding-system)
144 (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
145 *external-format-to-coding-system*)))
146
147 ;;; Unix signals
148
149 (defun sigint-handler ()
150 (with-simple-restart (continue "Continue from SIGINT handler.")
151 (invoke-debugger "SIGINT")))
152
153 (defun make-sigint-handler (process)
154 (lambda (&rest args)
155 (declare (ignore args))
156 (mp:process-interrupt process #'sigint-handler)))
157
158 (defun set-sigint-handler ()
159 ;; Set SIGINT handler on Swank request handler thread.
160 #-win32
161 (sys::set-signal-handler +sigint+
162 (make-sigint-handler mp:*current-process*)))
163
164 #-win32
165 (defimplementation install-sigint-handler (handler)
166 (sys::set-signal-handler +sigint+
167 (let ((self mp:*current-process*))
168 (lambda (&rest args)
169 (declare (ignore args))
170 (mp:process-interrupt self handler)))))
171
172 (defimplementation call-without-interrupts (fn)
173 (lw:without-interrupts (funcall fn)))
174
175 (defimplementation getpid ()
176 #+win32 (win32:get-current-process-id)
177 #-win32 (system::getpid))
178
179 (defimplementation lisp-implementation-type-name ()
180 "lispworks")
181
182 (defimplementation set-default-directory (directory)
183 (namestring (hcl:change-directory directory)))
184
185 ;;;; Documentation
186
187 (defimplementation arglist (symbol-or-function)
188 (let ((arglist (lw:function-lambda-list symbol-or-function)))
189 (etypecase arglist
190 ((member :dont-know)
191 :not-available)
192 (list
193 arglist))))
194
195 (defimplementation function-name (function)
196 (nth-value 2 (function-lambda-expression function)))
197
198 (defimplementation macroexpand-all (form)
199 (walker:walk-form form))
200
201 (defun generic-function-p (object)
202 (typep object 'generic-function))
203
204 (defimplementation describe-symbol-for-emacs (symbol)
205 "Return a plist describing SYMBOL.
206 Return NIL if the symbol is unbound."
207 (let ((result '()))
208 (labels ((first-line (string)
209 (let ((pos (position #\newline string)))
210 (if (null pos) string (subseq string 0 pos))))
211 (doc (kind &optional (sym symbol))
212 (let ((string (or (documentation sym kind))))
213 (if string
214 (first-line string)
215 :not-documented)))
216 (maybe-push (property value)
217 (when value
218 (setf result (list* property value result)))))
219 (maybe-push
220 :variable (when (boundp symbol)
221 (doc 'variable)))
222 (maybe-push
223 :generic-function (if (and (fboundp symbol)
224 (generic-function-p (fdefinition symbol)))
225 (doc 'function)))
226 (maybe-push
227 :function (if (and (fboundp symbol)
228 (not (generic-function-p (fdefinition symbol))))
229 (doc 'function)))
230 (maybe-push
231 :setf (let ((setf-name (sys:underlying-setf-name `(setf ,symbol))))
232 (if (fboundp setf-name)
233 (doc 'setf))))
234 (maybe-push
235 :class (if (find-class symbol nil)
236 (doc 'class)))
237 result)))
238
239 (defimplementation describe-definition (symbol type)
240 (ecase type
241 (:variable (describe-symbol symbol))
242 (:class (describe (find-class symbol)))
243 ((:function :generic-function) (describe-function symbol))
244 (:setf (describe-function (sys:underlying-setf-name `(setf ,symbol))))))
245
246 (defun describe-function (symbol)
247 (cond ((fboundp symbol)
248 (format t "(~A ~/pprint-fill/)~%~%~:[(not documented)~;~:*~A~]~%"
249 symbol
250 (lispworks:function-lambda-list symbol)
251 (documentation symbol 'function))
252 (describe (fdefinition symbol)))
253 (t (format t "~S is not fbound" symbol))))
254
255 (defun describe-symbol (sym)
256 (format t "~A is a symbol in package ~A." sym (symbol-package sym))
257 (when (boundp sym)
258 (format t "~%~%Value: ~A" (symbol-value sym)))
259 (let ((doc (documentation sym 'variable)))
260 (when doc
261 (format t "~%~%Variable documentation:~%~A" doc)))
262 (when (fboundp sym)
263 (describe-function sym)))
264
265 ;;; Debugging
266
267 (defclass slime-env (env:environment)
268 ((debugger-hook :initarg :debugger-hoook)))
269
270 (defun slime-env (hook io-bindings)
271 (make-instance 'slime-env :name "SLIME Environment"
272 :io-bindings io-bindings
273 :debugger-hoook hook))
274
275 (defmethod env-internals:environment-display-notifier
276 ((env slime-env) &key restarts condition)
277 (declare (ignore restarts condition))
278 (funcall (swank-sym :swank-debugger-hook) condition *debugger-hook*)
279 ;; nil
280 )
281
282 (defmethod env-internals:environment-display-debugger ((env slime-env))
283 *debug-io*)
284
285 (defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args)
286 (apply (swank-sym :y-or-n-p-in-emacs) msg args))
287
288 (defimplementation call-with-debugger-hook (hook fun)
289 (let ((*debugger-hook* hook))
290 (env:with-environment ((slime-env hook '()))
291 (funcall fun))))
292
293 (defimplementation install-debugger-globally (function)
294 (setq *debugger-hook* function)
295 (setf (env:environment) (slime-env function '())))
296
297 (defvar *sldb-top-frame*)
298
299 (defun interesting-frame-p (frame)
300 (cond ((or (dbg::call-frame-p frame)
301 (dbg::derived-call-frame-p frame)
302 (dbg::foreign-frame-p frame)
303 (dbg::interpreted-call-frame-p frame))
304 t)
305 ((dbg::catch-frame-p frame) dbg:*print-catch-frames*)
306 ((dbg::binding-frame-p frame) dbg:*print-binding-frames*)
307 ((dbg::handler-frame-p frame) dbg:*print-handler-frames*)
308 ((dbg::restart-frame-p frame) dbg:*print-restart-frames*)
309 ((dbg::open-frame-p frame) dbg:*print-open-frames*)
310 (t nil)))
311
312 (defun nth-next-frame (frame n)
313 "Unwind FRAME N times."
314 (do ((frame frame (dbg::frame-next frame))
315 (i n (if (interesting-frame-p frame) (1- i) i)))
316 ((or (not frame)
317 (and (interesting-frame-p frame) (zerop i)))
318 frame)))
319
320 (defun nth-frame (index)
321 (nth-next-frame *sldb-top-frame* index))
322
323 (defun find-top-frame ()
324 "Return the most suitable top-frame for the debugger."
325 (or (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*)
326 (nth-next-frame frame 1)))
327 ((or (null frame) ; no frame found!
328 (and (dbg::call-frame-p frame)
329 (eq (dbg::call-frame-function-name frame)
330 'invoke-debugger)))
331 (nth-next-frame frame 1)))
332 ;; if we can't find a invoke-debugger frame, take any old frame at the top
333 (dbg::debugger-stack-current-frame dbg::*debugger-stack*)))
334
335 (defimplementation call-with-debugging-environment (fn)
336 (dbg::with-debugger-stack ()
337 (let ((*sldb-top-frame* (find-top-frame)))
338 (funcall fn))))
339
340 (defimplementation compute-backtrace (start end)
341 (let ((end (or end most-positive-fixnum))
342 (backtrace '()))
343 (do ((frame (nth-frame start) (dbg::frame-next frame))
344 (i start))
345 ((or (not frame) (= i end)) (nreverse backtrace))
346 (when (interesting-frame-p frame)
347 (incf i)
348 (push frame backtrace)))))
349
350 (defun frame-actual-args (frame)
351 (let ((*break-on-signals* nil))
352 (mapcar (lambda (arg)
353 (case arg
354 ((&rest &optional &key) arg)
355 (t
356 (handler-case (dbg::dbg-eval arg frame)
357 (error (e) (format nil "<~A>" arg))))))
358 (dbg::call-frame-arglist frame))))
359
360 (defimplementation print-frame (frame stream)
361 (cond ((dbg::call-frame-p frame)
362 (format stream "~S ~S"
363 (dbg::call-frame-function-name frame)
364 (frame-actual-args frame)))
365 (t (princ frame stream))))
366
367 (defun frame-vars (frame)
368 (first (dbg::frame-locals-format-list frame #'list 75 0)))
369
370 (defimplementation frame-locals (n)
371 (let ((frame (nth-frame n)))
372 (if (dbg::call-frame-p frame)
373 (mapcar (lambda (var)
374 (destructuring-bind (name value symbol location) var
375 (declare (ignore name location))
376 (list :name symbol :id 0
377 :value value)))
378 (frame-vars frame)))))
379
380 (defimplementation frame-var-value (frame var)
381 (let ((frame (nth-frame frame)))
382 (destructuring-bind (_n value _s _l) (nth var (frame-vars frame))
383 (declare (ignore _n _s _l))
384 value)))
385
386 (defimplementation frame-source-location-for-emacs (frame)
387 (let ((frame (nth-frame frame))
388 (callee (if (plusp frame) (nth-frame (1- frame)))))
389 (if (dbg::call-frame-p frame)
390 (let ((dspec (dbg::call-frame-function-name frame))
391 (cname (and (dbg::call-frame-p callee)
392 (dbg::call-frame-function-name callee))))
393 (if dspec
394 (frame-location dspec cname))))))
395
396 (defimplementation eval-in-frame (form frame-number)
397 (let ((frame (nth-frame frame-number)))
398 (dbg::dbg-eval form frame)))
399
400 (defimplementation return-from-frame (frame-number form)
401 (let* ((frame (nth-frame frame-number))
402 (return-frame (dbg::find-frame-for-return frame)))
403 (dbg::dbg-return-from-call-frame frame form return-frame
404 dbg::*debugger-stack*)))
405
406 (defimplementation restart-frame (frame-number)
407 (let ((frame (nth-frame frame-number)))
408 (dbg::restart-frame frame :same-args t)))
409
410 (defimplementation disassemble-frame (frame-number)
411 (let* ((frame (nth-frame frame-number)))
412 (when (dbg::call-frame-p frame)
413 (let ((function (dbg::get-call-frame-function frame)))
414 (disassemble function)))))
415
416 ;;; Definition finding
417
418 (defun frame-location (dspec callee-name)
419 (let ((infos (dspec:find-dspec-locations dspec)))
420 (cond (infos
421 (destructuring-bind ((rdspec location) &rest _) infos
422 (declare (ignore _))
423 (let ((name (and callee-name (symbolp callee-name)
424 (string callee-name))))
425 (make-dspec-location rdspec location
426 `(:call-site ,name)))))
427 (t
428 (list :error (format nil "Source location not available for: ~S"
429 dspec))))))
430
431 (defimplementation find-definitions (name)
432 (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name)))
433 (loop for (dspec location) in locations
434 collect (list dspec (make-dspec-location dspec location)))))
435
436
437 ;;; Compilation
438
439 (defmacro with-swank-compilation-unit ((location &rest options) &body body)
440 (lw:rebinding (location)
441 `(let ((compiler::*error-database* '()))
442 (with-compilation-unit ,options
443 (multiple-value-prog1 (progn ,@body)
444 (signal-error-data-base compiler::*error-database*
445 ,location)
446 (signal-undefined-functions compiler::*unknown-functions*
447 ,location))))))
448
449 (defimplementation swank-compile-file (input-file output-file
450 load-p external-format)
451 (with-swank-compilation-unit (input-file)
452 (compile-file input-file
453 :output-file output-file
454 :load load-p
455 :external-format external-format)))
456
457 (defvar *within-call-with-compilation-hooks* nil
458 "Whether COMPILE-FILE was called from within CALL-WITH-COMPILATION-HOOKS.")
459
460 (defvar *undefined-functions-hash* nil
461 "Hash table to map info about undefined functions to pathnames.")
462
463 (lw:defadvice (compile-file compile-file-and-collect-notes :around)
464 (pathname &rest rest)
465 (multiple-value-prog1 (apply #'lw:call-next-advice pathname rest)
466 (when *within-call-with-compilation-hooks*
467 (maphash (lambda (unfun dspecs)
468 (dolist (dspec dspecs)
469 (let ((unfun-info (list unfun dspec)))
470 (unless (gethash unfun-info *undefined-functions-hash*)
471 (setf (gethash unfun-info *undefined-functions-hash*)
472 pathname)))))
473 compiler::*unknown-functions*))))
474
475 (defimplementation call-with-compilation-hooks (function)
476 (let ((compiler::*error-database* '())
477 (*undefined-functions-hash* (make-hash-table :test 'equal))
478 (*within-call-with-compilation-hooks* t))
479 (with-compilation-unit ()
480 (prog1 (funcall function)
481 (signal-error-data-base compiler::*error-database*)
482 (signal-undefined-functions compiler::*unknown-functions*)))))
483
484 (defun map-error-database (database fn)
485 (loop for (filename . defs) in database do
486 (loop for (dspec . conditions) in defs do
487 (dolist (c conditions)
488 (funcall fn filename dspec (if (consp c) (car c) c))))))
489
490 (defun lispworks-severity (condition)
491 (cond ((not condition) :warning)
492 (t (etypecase condition
493 (error :error)
494 (style-warning :warning)
495 (warning :warning)))))
496
497 (defun signal-compiler-condition (message location condition)
498 (check-type message string)
499 (signal
500 (make-instance 'compiler-condition :message message
501 :severity (lispworks-severity condition)
502 :location location
503 :original-condition condition)))
504
505 (defvar *temp-file-format* '(:utf-8 :eol-style :lf))
506
507 (defun compile-from-temp-file (string filename)
508 (unwind-protect
509 (progn
510 (with-open-file (s filename :direction :output
511 :if-exists :supersede
512 :external-format *temp-file-format*)
513
514 (write-string string s)
515 (finish-output s))
516 (multiple-value-bind (binary-filename warnings? failure?)
517 (compile-file filename :load t
518 :external-format *temp-file-format*)
519 (declare (ignore warnings?))
520 (when binary-filename
521 (delete-file binary-filename))
522 (not failure?)))
523 (delete-file filename)))
524
525 (defun dspec-function-name-position (dspec fallback)
526 (etypecase dspec
527 (cons (let ((name (dspec:dspec-primary-name dspec)))
528 (typecase name
529 ((or symbol string)
530 (list :function-name (string name)))
531 (t fallback))))
532 (null fallback)
533 (symbol (list :function-name (string dspec)))))
534
535 (defmacro with-fairly-standard-io-syntax (&body body)
536 "Like WITH-STANDARD-IO-SYNTAX but preserve *PACKAGE* and *READTABLE*."
537 (let ((package (gensym))
538 (readtable (gensym)))
539 `(let ((,package *package*)
540 (,readtable *readtable*))
541 (with-standard-io-syntax
542 (let ((*package* ,package)
543 (*readtable* ,readtable))
544 ,@body)))))
545
546 (defun skip-comments (stream)
547 (let ((pos0 (file-position stream)))
548 (cond ((equal (ignore-errors (list (read-delimited-list #\( stream)))
549 '(()))
550 (file-position stream (1- (file-position stream))))
551 (t (file-position stream pos0)))))
552
553 #-(or lispworks4.1 lispworks4.2) ; no dspec:parse-form-dspec prior to 4.3
554 (defun dspec-stream-position (stream dspec)
555 (with-fairly-standard-io-syntax
556 (loop (let* ((pos (progn (skip-comments stream) (file-position stream)))
557 (form (read stream nil '#1=#:eof)))
558 (when (eq form '#1#)
559 (return nil))
560 (labels ((check-dspec (form)
561 (when (consp form)
562 (let ((operator (car form)))
563 (case operator
564 ((progn)
565 (mapcar #'check-dspec
566 (cdr form)))
567 ((eval-when locally macrolet symbol-macrolet)
568 (mapcar #'check-dspec
569 (cddr form)))
570 ((in-package)
571 (let ((package (find-package (second form))))
572 (when package
573 (setq *package* package))))
574 (otherwise
575 (let ((form-dspec (dspec:parse-form-dspec form)))
576 (when (dspec:dspec-equal dspec form-dspec)
577 (return pos)))))))))
578 (check-dspec form))))))
579
580 (defun dspec-file-position (file dspec)
581 (let* ((*compile-file-pathname* (pathname file))
582 (*compile-file-truename* (truename *compile-file-pathname*))
583 (*load-pathname* *compile-file-pathname*)
584 (*load-truename* *compile-file-truename*))
585 (with-open-file (stream file)
586 (let ((pos
587 #-(or lispworks4.1 lispworks4.2)
588 (dspec-stream-position stream dspec)))
589 (if pos
590 (list :position (1+ pos))
591 (dspec-function-name-position dspec `(:position 1)))))))
592
593 (defun emacs-buffer-location-p (location)
594 (and (consp location)
595 (eq (car location) :emacs-buffer)))
596
597 (defun make-dspec-location (dspec location &optional hints)
598 (etypecase location
599 ((or pathname string)
600 (multiple-value-bind (file err)
601 (ignore-errors (namestring (truename location)))
602 (if err
603 (list :error (princ-to-string err))
604 (make-location `(:file ,file)
605 (dspec-file-position file dspec)
606 hints))))
607 (symbol
608 `(:error ,(format nil "Cannot resolve location: ~S" location)))
609 ((satisfies emacs-buffer-location-p)
610 (destructuring-bind (_ buffer offset string) location
611 (declare (ignore _ string))
612 (make-location `(:buffer ,buffer)
613 (dspec-function-name-position dspec `(:offset ,offset 0))
614 hints)))))
615
616 (defun make-dspec-progenitor-location (dspec location)
617 (let ((canon-dspec (dspec:canonicalize-dspec dspec)))
618 (make-dspec-location
619 (if canon-dspec
620 (if (dspec:local-dspec-p canon-dspec)
621 (dspec:dspec-progenitor canon-dspec)
622 canon-dspec)
623 nil)
624 location)))
625
626 (defun signal-error-data-base (database &optional location)
627 (map-error-database
628 database
629 (lambda (filename dspec condition)
630 (signal-compiler-condition
631 (format nil "~A" condition)
632 (make-dspec-progenitor-location dspec (or location filename))
633 condition))))
634
635 (defun unmangle-unfun (symbol)
636 "Converts symbols like 'SETF::|\"CL-USER\" \"GET\"| to
637 function names like \(SETF GET)."
638 (cond ((sys::setf-symbol-p symbol)
639 (sys::setf-pair-from-underlying-name symbol))
640 (t symbol)))
641
642 (defun signal-undefined-functions (htab &optional filename)
643 (maphash (lambda (unfun dspecs)
644 (dolist (dspec dspecs)
645 (signal-compiler-condition
646 (format nil "Undefined function ~A" (unmangle-unfun unfun))
647 (make-dspec-progenitor-location dspec
648 (or filename
649 (gethash (list unfun dspec)
650 *undefined-functions-hash*)))
651 nil)))
652 htab))
653
654 (defimplementation swank-compile-string (string &key buffer position filename
655 policy)
656 (declare (ignore filename policy))
657 (assert buffer)
658 (assert position)
659 (let* ((location (list :emacs-buffer buffer position string))
660 (tmpname (hcl:make-temp-file nil "lisp")))
661 (with-swank-compilation-unit (location)
662 (compile-from-temp-file
663 (with-output-to-string (s)
664 (let ((*print-radix* t))
665 (print `(eval-when (:compile-toplevel)
666 (setq dspec::*location* (list ,@location)))
667 s))
668 (write-string string s))
669 tmpname))))
670
671 ;;; xref
672
673 (defmacro defxref (name function)
674 `(defimplementation ,name (name)
675 (xref-results (,function name))))
676
677 (defxref who-calls hcl:who-calls)
678 (defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too
679 (defxref calls-who hcl:calls-who)
680 (defxref list-callers list-callers-internal)
681 ;; (defxref list-callees list-callees-internal)
682
683 (defun list-callers-internal (name)
684 (let ((callers (make-array 100
685 :fill-pointer 0
686 :adjustable t)))
687 (hcl:sweep-all-objects
688 #'(lambda (object)
689 (when (and #+Harlequin-PC-Lisp (low:compiled-code-p object)
690 #-Harlequin-PC-Lisp (sys::callablep object)
691 (system::find-constant$funcallable name object))
692 (vector-push-extend object callers))))
693 ;; Delay dspec:object-dspec until after sweep-all-objects
694 ;; to reduce allocation problems.
695 (loop for object across callers
696 collect (if (symbolp object)
697 (list 'function object)
698 (or (dspec:object-dspec object) object)))))
699
700 ;; only for lispworks 4.2 and above
701 #-lispworks4.1
702 (progn
703 (defxref who-references hcl:who-references)
704 (defxref who-binds hcl:who-binds)
705 (defxref who-sets hcl:who-sets))
706
707 (defimplementation who-specializes (classname)
708 (let ((methods (clos:class-direct-methods (find-class classname))))
709 (xref-results (mapcar #'dspec:object-dspec methods))))
710
711 (defun xref-results (dspecs)
712 (flet ((frob-locs (dspec locs)
713 (cond (locs
714 (loop for (name loc) in locs
715 collect (list name (make-dspec-location name loc))))
716 (t `((,dspec (:error "Source location not available")))))))
717 (loop for dspec in dspecs
718 append (frob-locs dspec (dspec:dspec-definition-locations dspec)))))
719
720 ;;; Inspector
721
722 (defmethod emacs-inspect ((o t))
723 (lispworks-inspect o))
724
725 (defmethod emacs-inspect ((o function))
726 (lispworks-inspect o))
727
728 ;; FIXME: slot-boundp-using-class in LW works with names so we can't
729 ;; use our method in swank.lisp.
730 (defmethod emacs-inspect ((o standard-object))
731 (lispworks-inspect o))
732
733 (defun lispworks-inspect (o)
734 (multiple-value-bind (names values _getter _setter type)
735 (lw:get-inspector-values o nil)
736 (declare (ignore _getter _setter))
737 (append
738 (label-value-line "Type" type)
739 (loop for name in names
740 for value in values
741 append (label-value-line name value)))))
742
743 ;;; Miscellaneous
744
745 (defimplementation quit-lisp ()
746 (lispworks:quit))
747
748 ;;; Tracing
749
750 (defun parse-fspec (fspec)
751 "Return a dspec for FSPEC."
752 (ecase (car fspec)
753 ((:defmethod) `(method ,(cdr fspec)))))
754
755 (defun tracedp (dspec)
756 (member dspec (eval '(trace)) :test #'equal))
757
758 (defun toggle-trace-aux (dspec)
759 (cond ((tracedp dspec)
760 (eval `(untrace ,dspec))
761 (format nil "~S is now untraced." dspec))
762 (t
763 (eval `(trace (,dspec)))
764 (format nil "~S is now traced." dspec))))
765
766 (defimplementation toggle-trace (fspec)
767 (toggle-trace-aux (parse-fspec fspec)))
768
769 ;;; Multithreading
770
771 (defimplementation initialize-multiprocessing (continuation)
772 (cond ((not mp::*multiprocessing*)
773 (push (list "Initialize SLIME" '() continuation)
774 mp:*initial-processes*)
775 (mp:initialize-multiprocessing))
776 (t (funcall continuation))))
777
778 (defimplementation spawn (fn &key name)
779 (mp:process-run-function name () fn))
780
781 (defvar *id-lock* (mp:make-lock))
782 (defvar *thread-id-counter* 0)
783
784 (defimplementation thread-id (thread)
785 (mp:with-lock (*id-lock*)
786 (or (getf (mp:process-plist thread) 'id)
787 (setf (getf (mp:process-plist thread) 'id)
788 (incf *thread-id-counter*)))))
789
790 (defimplementation find-thread (id)
791 (find id (mp:list-all-processes)
792 :key (lambda (p) (getf (mp:process-plist p) 'id))))
793
794 (defimplementation thread-name (thread)
795 (mp:process-name thread))
796
797 (defimplementation thread-status (thread)
798 (format nil "~A ~D"
799 (mp:process-whostate thread)
800 (mp:process-priority thread)))
801
802 (defimplementation make-lock (&key name)
803 (mp:make-lock :name name))
804
805 (defimplementation call-with-lock-held (lock function)
806 (mp:with-lock (lock) (funcall function)))
807
808 (defimplementation current-thread ()
809 mp:*current-process*)
810
811 (defimplementation all-threads ()
812 (mp:list-all-processes))
813
814 (defimplementation interrupt-thread (thread fn)
815 (mp:process-interrupt thread fn))
816
817 (defimplementation kill-thread (thread)
818 (mp:process-kill thread))
819
820 (defimplementation thread-alive-p (thread)
821 (mp:process-alive-p thread))
822
823 (defstruct (mailbox (:conc-name mailbox.))
824 (mutex (mp:make-lock :name "thread mailbox"))
825 (queue '() :type list))
826
827 (defvar *mailbox-lock* (mp:make-lock))
828
829 (defun mailbox (thread)
830 (mp:with-lock (*mailbox-lock*)
831 (or (getf (mp:process-plist thread) 'mailbox)
832 (setf (getf (mp:process-plist thread) 'mailbox)
833 (make-mailbox)))))
834
835 (defimplementation receive-if (test &optional timeout)
836 (let* ((mbox (mailbox mp:*current-process*))
837 (lock (mailbox.mutex mbox)))
838 (assert (or (not timeout) (eq timeout t)))
839 (loop
840 (check-slime-interrupts)
841 (mp:with-lock (lock "receive-if/try")
842 (let* ((q (mailbox.queue mbox))
843 (tail (member-if test q)))
844 (when tail
845 (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
846 (return (car tail)))))
847 (when (eq timeout t) (return (values nil t)))
848 (mp:process-wait-with-timeout
849 "receive-if" 0.3 (lambda () (some test (mailbox.queue mbox)))))))
850
851 (defimplementation send (thread message)
852 (let ((mbox (mailbox thread)))
853 (mp:with-lock ((mailbox.mutex mbox))
854 (setf (mailbox.queue mbox)
855 (nconc (mailbox.queue mbox) (list message))))))
856
857 (defimplementation set-default-initial-binding (var form)
858 (setq mp:*process-initial-bindings*
859 (acons var `(eval (quote ,form))
860 mp:*process-initial-bindings* )))
861
862 ;;; Some intergration with the lispworks environment
863
864 (defun swank-sym (name) (find-symbol (string name) :swank))
865
866
867 ;;;; Weak hashtables
868
869 (defimplementation make-weak-key-hash-table (&rest args)
870 (apply #'make-hash-table :weak-kind :key args))
871
872 (defimplementation make-weak-value-hash-table (&rest args)
873 (apply #'make-hash-table :weak-kind :value args))

  ViewVC Help
Powered by ViewVC 1.1.5