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

Contents of /slime/swank-ccl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Sun Jul 26 08:00:40 2009 UTC (4 years, 8 months ago) by heller
Branch: MAIN
* swank-ccl.lisp: New file.  An updated version of
swank-openmcl.lisp in preparation for a slew of changes to CCL and
to honor the new name.

* swank-loader.lisp (*sysdep-files*): Use it.

By Gail Zacharias <gz@clozure.com>
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; openmcl-swank.lisp --- SLIME backend for OpenMCL.
4 ;;;
5 ;;; Copyright (C) 2003, James Bielman <jamesjb@jamesjb.com>
6 ;;;
7 ;;; This program is licensed under the terms of the Lisp Lesser GNU
8 ;;; Public License, known as the LLGPL, and distributed with OpenMCL
9 ;;; as the file "LICENSE". The LLGPL consists of a preamble and the
10 ;;; LGPL, which is distributed with OpenMCL as the file "LGPL". Where
11 ;;; these conflict, the preamble takes precedence.
12 ;;;
13 ;;; The LLGPL is also available online at
14 ;;; http://opensource.franz.com/preamble.html
15
16 ;;;
17 ;;; This is the beginning of a Slime backend for OpenMCL. It has been
18 ;;; tested only with OpenMCL version 0.14-030901 on Darwin --- I would
19 ;;; be interested in hearing the results with other versions.
20 ;;;
21 ;;; Additionally, reporting the positions of warnings accurately requires
22 ;;; a small patch to the OpenMCL file compiler, which may be found at:
23 ;;;
24 ;;; http://www.jamesjb.com/slime/openmcl-warning-position.diff
25 ;;;
26 ;;; Things that work:
27 ;;;
28 ;;; * Evaluation of forms with C-M-x.
29 ;;; * Compilation of defuns with C-c C-c.
30 ;;; * File compilation with C-c C-k.
31 ;;; * Most of the debugger functionality, except EVAL-IN-FRAME,
32 ;;; FRAME-SOURCE-LOCATION, and FRAME-CATCH-TAGS.
33 ;;; * Macroexpanding with C-c RET.
34 ;;; * Disassembling the symbol at point with C-c M-d.
35 ;;; * Describing symbol at point with C-c C-d.
36 ;;; * Compiler warnings are trapped and sent to Emacs using the buffer
37 ;;; position of the offending top level form.
38 ;;; * Symbol completion and apropos.
39 ;;;
40 ;;; Things that sort of work:
41 ;;;
42 ;;; * WHO-CALLS is implemented but is only able to return the file a
43 ;;; caller is defined in---source location information is not
44 ;;; available.
45 ;;;
46 ;;; Things that aren't done yet:
47 ;;;
48 ;;; * Cross-referencing.
49 ;;; * Due to unimplementation functionality the test suite does not
50 ;;; run correctly (it hangs upon entering the debugger).
51 ;;;
52
53 (in-package :swank-backend)
54
55 ;; Backward compatibility
56 (eval-when (:compile-toplevel)
57 (unless (fboundp 'ccl:compute-applicable-methods-using-classes)
58 (compile-file (make-pathname :name "swank-openmcl" :type "lisp" :defaults swank-loader::*source-directory*)
59 :output-file (make-pathname :name "swank-ccl" :defaults swank-loader::*fasl-directory*)
60 :verbose t)
61 (invoke-restart (find-restart 'ccl::skip-compile-file))))
62
63 (eval-when (:compile-toplevel :execute :load-toplevel)
64 (assert (and (= ccl::*openmcl-major-version* 1)
65 (>= ccl::*openmcl-minor-version* 4))
66 () "This file needs CCL version 1.4 or newer"))
67
68 (import-from :ccl *gray-stream-symbols* :swank-backend)
69
70 (eval-when (:compile-toplevel :load-toplevel :execute)
71 (require 'xref))
72
73 ;;; swank-mop
74
75 (import-to-swank-mop
76 '( ;; classes
77 cl:standard-generic-function
78 ccl:standard-slot-definition
79 cl:method
80 cl:standard-class
81 ccl:eql-specializer
82 openmcl-mop:finalize-inheritance
83 openmcl-mop:compute-applicable-methods-using-classes
84 ;; standard-class readers
85 openmcl-mop:class-default-initargs
86 openmcl-mop:class-direct-default-initargs
87 openmcl-mop:class-direct-slots
88 openmcl-mop:class-direct-subclasses
89 openmcl-mop:class-direct-superclasses
90 openmcl-mop:class-finalized-p
91 cl:class-name
92 openmcl-mop:class-precedence-list
93 openmcl-mop:class-prototype
94 openmcl-mop:class-slots
95 openmcl-mop:specializer-direct-methods
96 ;; eql-specializer accessors
97 openmcl-mop:eql-specializer-object
98 ;; generic function readers
99 openmcl-mop:generic-function-argument-precedence-order
100 openmcl-mop:generic-function-declarations
101 openmcl-mop:generic-function-lambda-list
102 openmcl-mop:generic-function-methods
103 openmcl-mop:generic-function-method-class
104 openmcl-mop:generic-function-method-combination
105 openmcl-mop:generic-function-name
106 ;; method readers
107 openmcl-mop:method-generic-function
108 openmcl-mop:method-function
109 openmcl-mop:method-lambda-list
110 openmcl-mop:method-specializers
111 openmcl-mop:method-qualifiers
112 ;; slot readers
113 openmcl-mop:slot-definition-allocation
114 openmcl-mop:slot-definition-documentation
115 openmcl-mop:slot-value-using-class
116 openmcl-mop:slot-definition-initargs
117 openmcl-mop:slot-definition-initform
118 openmcl-mop:slot-definition-initfunction
119 openmcl-mop:slot-definition-name
120 openmcl-mop:slot-definition-type
121 openmcl-mop:slot-definition-readers
122 openmcl-mop:slot-definition-writers
123 openmcl-mop:slot-boundp-using-class
124 openmcl-mop:slot-makunbound-using-class))
125
126 (defmacro swank-sym (sym)
127 (let ((str (symbol-name sym)))
128 `(or (find-symbol ,str :swank)
129 (error "There is no symbol named ~a in the SWANK package" ,str))))
130
131
132 ;;; TCP Server
133
134 (defimplementation preferred-communication-style ()
135 :spawn)
136
137 (defimplementation create-socket (host port)
138 (ccl:make-socket :connect :passive :local-port port
139 :local-host host :reuse-address t))
140
141 (defimplementation local-port (socket)
142 (ccl:local-port socket))
143
144 (defimplementation close-socket (socket)
145 (close socket))
146
147 (defimplementation accept-connection (socket &key external-format
148 buffering timeout)
149 (declare (ignore buffering timeout))
150 (ccl:accept-connection socket :wait t
151 :stream-args (and external-format
152 `(:external-format ,external-format))))
153
154 (defvar *external-format-to-coding-system*
155 '((:iso-8859-1
156 "latin-1" "latin-1-unix" "iso-latin-1-unix"
157 "iso-8859-1" "iso-8859-1-unix")
158 (:utf-8 "utf-8" "utf-8-unix")))
159
160 (defimplementation find-external-format (coding-system)
161 (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
162 *external-format-to-coding-system*)))
163
164 ;;; Unix signals
165
166 (defimplementation call-without-interrupts (fn)
167 ;; This prevents the current thread from being interrupted, but it doesn't
168 ;; keep other threads from running concurrently, so it's not an appropriate
169 ;; replacement for locking.
170 (ccl:without-interrupts (funcall fn)))
171
172 (defimplementation getpid ()
173 (ccl::getpid))
174
175 (defimplementation lisp-implementation-type-name ()
176 "ccl")
177
178 ;;; Arglist
179
180 (defimplementation arglist (fname)
181 (multiple-value-bind (arglist binding) (let ((*break-on-signals* nil))
182 (ccl:arglist fname))
183 (if binding
184 arglist
185 :not-available)))
186
187 (defimplementation function-name (function)
188 (ccl:function-name function))
189
190 (defmethod declaration-arglist ((decl-identifier (eql 'optimize)))
191 (let ((flags (ccl:declaration-information decl-identifier)))
192 (if flags
193 `(&any ,flags)
194 (call-next-method))))
195
196 ;;; Compilation
197
198 (defun handle-compiler-warning (condition)
199 "Resignal a ccl:compiler-warning as swank-backend:compiler-warning."
200 (signal (make-condition
201 'compiler-condition
202 :original-condition condition
203 :message (format nil "~A" condition)
204 :short-message (compiler-warning-short-message condition)
205 :severity (compiler-warning-severity condition)
206 :location (source-note-to-source-location
207 (ccl:compiler-warning-source-note condition)
208 (lambda () "Unknown source")
209 (ccl:compiler-warning-function-name condition)))))
210
211 (defgeneric compiler-warning-severity (condition))
212 (defmethod compiler-warning-severity ((c ccl:compiler-warning)) :warning)
213 (defmethod compiler-warning-severity ((c ccl:style-warning)) :style-warning)
214
215 (defgeneric compiler-warning-short-message (condition))
216
217 ;; Pretty much the same as ccl:report-compiler-warning but
218 ;; without the source position and function name stuff.
219 (defmethod compiler-warning-short-message ((c ccl:compiler-warning))
220 (with-output-to-string (stream)
221 (ccl:report-compiler-warning c stream :short t)))
222
223 (defimplementation call-with-compilation-hooks (function)
224 (handler-bind ((ccl:compiler-warning 'handle-compiler-warning))
225 (let ((ccl:*merge-compiler-warnings* nil))
226 (funcall function))))
227
228 (defimplementation swank-compile-file (input-file output-file
229 load-p external-format)
230 (with-compilation-hooks ()
231 (compile-file input-file
232 :output-file output-file
233 :load load-p
234 :external-format external-format)))
235
236 ;; Use a temp file rather than in-core compilation in order to handle eval-when's
237 ;; as compile-time.
238 (defimplementation swank-compile-string (string &key buffer position filename
239 policy)
240 (declare (ignore policy))
241 (with-compilation-hooks ()
242 (let ((temp-file-name (ccl:temp-pathname))
243 (ccl:*save-source-locations* t))
244 (unwind-protect
245 (progn
246 (with-open-file (s temp-file-name :direction :output
247 :if-exists :error)
248 (write-string string s))
249 (let ((binary-filename (compile-temp-file
250 temp-file-name filename buffer position)))
251 (delete-file binary-filename)))
252 (delete-file temp-file-name)))))
253
254 (defvar *temp-file-map* (make-hash-table :test #'equal)
255 "A mapping from tempfile names to Emacs buffer names.")
256
257 (defun compile-temp-file (temp-file-name buffer-file-name buffer-name offset)
258 (compile-file temp-file-name
259 :load t
260 :compile-file-original-truename
261 (or buffer-file-name
262 (progn
263 (setf (gethash temp-file-name *temp-file-map*)
264 buffer-name)
265 temp-file-name))
266 :compile-file-original-buffer-offset (1- offset)))
267
268 (defimplementation save-image (filename &optional restart-function)
269 (ccl:save-application filename :toplevel-function restart-function))
270
271 ;;; Cross-referencing
272
273 (defun xref-locations (relation name &optional inverse)
274 (delete-duplicates
275 (mapcan #'find-definitions
276 (if inverse
277 (ccl:get-relation relation name :wild :exhaustive t)
278 (ccl:get-relation relation :wild name :exhaustive t)))
279 :test 'equal))
280
281 (defimplementation who-binds (name)
282 (xref-locations :binds name))
283
284 (defimplementation who-macroexpands (name)
285 (xref-locations :macro-calls name t))
286
287 (defimplementation who-references (name)
288 (remove-duplicates
289 (append (xref-locations :references name)
290 (xref-locations :sets name)
291 (xref-locations :binds name))
292 :test 'equal))
293
294 (defimplementation who-sets (name)
295 (xref-locations :sets name))
296
297 (defimplementation who-calls (name)
298 (remove-duplicates
299 (append
300 (xref-locations :direct-calls name)
301 (xref-locations :indirect-calls name)
302 (xref-locations :macro-calls name t))
303 :test 'equal))
304
305 (defimplementation who-specializes (class)
306 (delete-duplicates
307 (mapcar (lambda (m)
308 (car (find-definitions m)))
309 (ccl:specializer-direct-methods (if (symbolp class) (find-class class) class)))
310 :test 'equal))
311
312 (defimplementation list-callees (name)
313 (remove-duplicates
314 (append
315 (xref-locations :direct-calls name t)
316 (xref-locations :macro-calls name nil))
317 :test 'equal))
318
319 (defimplementation list-callers (symbol)
320 (delete-duplicates
321 (mapcan #'find-definitions (ccl:caller-functions symbol))
322 :test #'equal))
323
324 ;;; Profiling (alanr: lifted from swank-clisp)
325
326 (defimplementation profile (fname)
327 (eval `(mon:monitor ,fname))) ;monitor is a macro
328
329 (defimplementation profiled-functions ()
330 mon:*monitored-functions*)
331
332 (defimplementation unprofile (fname)
333 (eval `(mon:unmonitor ,fname))) ;unmonitor is a macro
334
335 (defimplementation unprofile-all ()
336 (mon:unmonitor))
337
338 (defimplementation profile-report ()
339 (mon:report-monitoring))
340
341 (defimplementation profile-reset ()
342 (mon:reset-all-monitoring))
343
344 (defimplementation profile-package (package callers-p methods)
345 (declare (ignore callers-p methods))
346 (mon:monitor-all package))
347
348 ;;; Debugging
349
350 (defun openmcl-set-debug-switches ()
351 (setq ccl:*fasl-save-definitions* nil)
352 (setq ccl:*fasl-save-doc-strings* t)
353 (setq ccl:*fasl-save-local-symbols* t)
354 (setq ccl:*save-arglist-info* t)
355 (setq ccl:*save-definitions* nil)
356 (setq ccl:*save-doc-strings* t)
357 (setq ccl:*save-local-symbols* t)
358 (ccl:start-xref))
359
360 (defimplementation call-with-debugging-environment (debugger-loop-fn)
361 (let* (;;(*debugger-hook* nil)
362 ;; don't let error while printing error take us down
363 (ccl:*signal-printing-errors* nil))
364 (funcall debugger-loop-fn)))
365
366 (defun find-repl-thread ()
367 ;; This is called for an async interrupt and is running in a random thread not
368 ;; selected by the user, so don't use thread-local vars such as *emacs-connection*.
369 (let* ((conn (funcall (swank-sym default-connection))))
370 (and conn
371 (let ((*break-on-signals* nil))
372 (ignore-errors ;; this errors if no repl-thread
373 (funcall (swank-sym repl-thread) conn))))))
374
375 (defimplementation call-with-debugger-hook (hook fun)
376 (let ((*debugger-hook* hook)
377 (ccl:*break-hook* hook)
378 (ccl:*select-interactive-process-hook* 'find-repl-thread))
379 (funcall fun)))
380
381 (defimplementation install-debugger-globally (function)
382 (setq *debugger-hook* function)
383 (setq ccl:*break-hook* function)
384 (setq ccl:*select-interactive-process-hook* 'find-repl-thread)
385 )
386
387 (let ((ccl::*warn-if-redefine-kernel* nil))
388 ;; Everybody (error, cerror, break, invoke-debugger, and async interrupts) ends up
389 ;; in CCL::BREAK-LOOP, which implements the default debugger. Regardless of how it
390 ;; was entered, make sure it runs with the swank connection state established so
391 ;; that i/o happens via emacs and there is no contention for the terminal (stdin).
392 (ccl:advise
393 ccl::break-loop
394 (if (symbol-value (swank-sym *emacs-connection*))
395 (:do-it)
396 (let ((conn (funcall (swank-sym default-connection))))
397 (if conn
398 (funcall (swank-sym call-with-connection) conn
399 (lambda () (:do-it)))
400 (:do-it))))
401 :when :around
402 :name swank-default-debugger-context))
403
404 (defun map-backtrace (function &optional
405 (start-frame-number 0)
406 (end-frame-number most-positive-fixnum))
407 "Call FUNCTION passing information about each stack frame
408 from frames START-FRAME-NUMBER to END-FRAME-NUMBER."
409 (ccl:map-call-frames function
410 :origin ccl:*top-error-frame*
411 :start-frame-number start-frame-number
412 :count (- end-frame-number start-frame-number)
413 :test (and (not t) ;(not (symbol-value (swank-sym *sldb-show-internal-frames*)))
414 'interesting-frame-p)))
415
416 ;; Exceptions
417 (defvar *interesting-internal-frames* ())
418
419 (defun interesting-frame-p (p context)
420 ;; A frame is interesting if it has at least one external symbol in its name.
421 (labels ((internal (obj)
422 ;; For a symbol, return true if the symbol is internal, i.e. not
423 ;; declared to be external. For a cons or list, everything
424 ;; must be internal. For a method, the name must be internal.
425 ;; Nothing else is internal.
426 (typecase obj
427 (cons (and (internal (car obj)) (internal (cdr obj))))
428 (symbol (and (eq (symbol-package obj) (find-package :ccl))
429 (eq :internal (nth-value 1 (find-symbol (symbol-name obj) :ccl)))
430 (not (member obj *interesting-internal-frames*))))
431 (method (internal (ccl:method-name obj)))
432 (t nil))))
433 (let* ((lfun (ccl:frame-function p context))
434 (internal-frame-p (internal (ccl:function-name lfun))))
435 #+debug (format t "~S is ~@[not ~]internal~%"
436 (ccl:function-name lfun)
437 (not internal-frame-p))
438 (not internal-frame-p))))
439
440
441 (defimplementation compute-backtrace (start-frame-number end-frame-number)
442 (let (result)
443 (map-backtrace (lambda (p context)
444 (push (list :frame p context) result))
445 start-frame-number end-frame-number)
446 (nreverse result)))
447
448 (defimplementation print-frame (frame stream)
449 (assert (eq (first frame) :frame))
450 (destructuring-bind (p context) (rest frame)
451 (let ((lfun (ccl:frame-function p context)))
452 (format stream "(~S" (or (ccl:function-name lfun) lfun))
453 (let* ((unavailable (cons nil nil))
454 (args (ccl:frame-supplied-arguments p context :unknown-marker unavailable)))
455 (declare (dynamic-extent unavailable))
456 (if (eq args unavailable)
457 (format stream " #<Unknown Arguments>")
458 (loop for arg in args
459 do (if (eq arg unavailable)
460 (format stream " #<Unavailable>")
461 (format stream " ~s" arg)))))
462 (format stream ")"))))
463
464 (defun call/frame (frame-number if-found)
465 (map-backtrace
466 (lambda (p context)
467 (return-from call/frame
468 (funcall if-found p context)))
469 frame-number))
470
471 (defmacro with-frame ((p context) frame-number &body body)
472 `(call/frame ,frame-number (lambda (,p ,context) . ,body)))
473
474 (defimplementation frame-var-value (frame var)
475 (with-frame (p context) frame
476 (cdr (nth var (ccl:frame-named-variables p context)))))
477
478 (defimplementation frame-locals (index)
479 (with-frame (p context) index
480 (loop for (name . value) in (ccl:frame-named-variables p context)
481 collect (list :name name :value value :id 0))))
482
483 (defimplementation frame-source-location (index)
484 (with-frame (p context) index
485 (multiple-value-bind (lfun pc) (ccl:frame-function p context)
486 (if pc
487 (pc-source-location lfun pc)
488 (function-source-location lfun)))))
489
490 (defimplementation eval-in-frame (form index)
491 (with-frame (p context) index
492 (let ((vars (ccl:frame-named-variables p context)))
493 (eval `(let ,(loop for (var . val) in vars collect `(,var ',val))
494 (declare (ignorable ,@(mapcar #'car vars)))
495 ,form)))))
496
497 (defimplementation return-from-frame (index form)
498 (let ((values (multiple-value-list (eval-in-frame form index))))
499 (with-frame (p context) index
500 (declare (ignore context))
501 (ccl:apply-in-frame p #'values values))))
502
503 (defimplementation restart-frame (index)
504 (with-frame (p context) index
505 (ccl:apply-in-frame p
506 (ccl:frame-function p context)
507 (ccl:frame-supplied-arguments p context))))
508
509 (defimplementation disassemble-frame (the-frame-number)
510 (with-frame (p context) the-frame-number
511 (multiple-value-bind (lfun pc) (ccl:frame-function p context)
512 (format t "LFUN: ~a~%PC: ~a FP: #x~x CONTEXT: ~a~%" lfun pc p context)
513 (disassemble lfun))))
514
515
516 ;; CCL commit r11373 | gz | 2008-11-16 16:35:28 +0100 (Sun, 16 Nov 2008)
517 ;; contains some interesting details:
518 ;;
519 ;; Source location are recorded in CCL:SOURCE-NOTE's, which are objects
520 ;; with accessors CCL:SOURCE-NOTE-FILENAME, CCL:SOURCE-NOTE-START-POS,
521 ;; CCL:SOURCE-NOTE-END-POS and CCL:SOURCE-NOTE-TEXT. The start and end
522 ;; positions are file positions (not character positions). The text will
523 ;; be NIL unless text recording was on at read-time. If the original
524 ;; file is still available, you can force missing source text to be read
525 ;; from the file at runtime via CCL:ENSURE-SOURCE-NOTE-TEXT.
526 ;;
527 ;; Source-note's are associated with definitions (via record-source-file)
528 ;; and also stored in function objects (including anonymous and nested
529 ;; functions). The former can be retrieved via
530 ;; CCL:FIND-DEFINITION-SOURCES, the latter via CCL:FUNCTION-SOURCE-NOTE.
531 ;;
532 ;; The recording behavior is controlled by the new variable
533 ;; CCL:*SAVE-SOURCE-LOCATIONS*:
534 ;;
535 ;; If NIL, don't store source-notes in function objects, and store only
536 ;; the filename for definitions (the latter only if
537 ;; *record-source-file* is true).
538 ;;
539 ;; If T, store source-notes, including a copy of the original source
540 ;; text, for function objects and definitions (the latter only if
541 ;; *record-source-file* is true).
542 ;;
543 ;; If :NO-TEXT, store source-notes, but without saved text, for
544 ;; function objects and defintions (the latter only if
545 ;; *record-source-file* is true). This is the default.
546 ;;
547 ;; PC to source mapping is controlled by the new variable
548 ;; CCL:*RECORD-PC-MAPPING*. If true (the default), functions store a
549 ;; compressed table mapping pc offsets to corresponding source locations.
550 ;; This can be retrieved by (CCL:FIND-SOURCE-NOTE-AT-PC function pc)
551 ;; which returns a source-note for the source at offset pc in the
552 ;; function.
553 ;;
554 ;; Currently the only thing that makes use of any of this is the
555 ;; disassembler. ILISP and current version of Slime still use
556 ;; backward-compatible functions that deal with filenames only. The plan
557 ;; is to make Slime, and our IDE, use this eventually.
558
559 (defun function-source-location (function)
560 (source-note-to-source-location
561 (ccl:function-source-note function)
562 (lambda ()
563 (format nil "Function has no source note: ~A" function))
564 (ccl:function-name function)))
565
566 (defun pc-source-location (function pc)
567 (source-note-to-source-location
568 (or (ccl:find-source-note-at-pc function pc)
569 (ccl:function-source-note function))
570 (lambda ()
571 (format nil "No source note at PC: ~a[~d]" function pc))
572 (ccl:function-name function)))
573
574 (defun source-note-to-source-location (source if-nil-thunk &optional name)
575 (labels ((filename-to-buffer (filename)
576 (cond ((gethash filename *temp-file-map*)
577 (list :buffer (gethash filename *temp-file-map*)))
578 ((probe-file filename)
579 (list :file (ccl:native-translated-namestring (truename filename))))
580 (t (error "File ~s doesn't exist" filename)))))
581 (handler-case
582 (cond ((ccl:source-note-p source)
583 (let* ((full-text (ccl:source-note-text source))
584 (file-name (ccl:source-note-filename source))
585 (start-pos (ccl:source-note-start-pos source)))
586 (make-location
587 (when file-name (filename-to-buffer file-name))
588 (when start-pos (list :position (1+ start-pos)))
589 (when full-text (list :snippet (subseq full-text 0 (min 40 (length full-text))))))))
590 ((and source name)
591 (make-location
592 (filename-to-buffer source)
593 (list :function-name (let ((*package* (find-package :swank-io-package))) ;; should be buffer package.
594 (with-standard-io-syntax
595 (princ-to-string (if (functionp name)
596 (ccl:function-name name)
597 name)))))))
598 (t `(:error ,(funcall if-nil-thunk))))
599 (error (c) `(:error ,(princ-to-string c))))))
600
601 (defimplementation find-definitions (obj)
602 (loop for ((type . name) . sources) in (ccl:find-definition-sources obj)
603 collect (list (definition-name type name)
604 (source-note-to-source-location
605 (find-if-not #'null sources)
606 (lambda () "No source-note available")
607 name))))
608
609 (defimplementation find-source-location (obj)
610 (let* ((defs (ccl:find-definition-sources obj))
611 (best-def (or (find (ccl:name-of obj) defs :key #'cdar :test #'equal)
612 (car defs)))
613 (note (find-if-not #'null (cdr best-def))))
614 (when note
615 (source-note-to-source-location
616 note
617 (lambda () "No source note available")))))
618
619 (defun definition-name (type object)
620 (list (ccl:definition-type-name type) (ccl:name-of object)))
621
622 ;;; Utilities
623
624 (defimplementation describe-symbol-for-emacs (symbol)
625 (let ((result '()))
626 (flet ((doc (kind &optional (sym symbol))
627 (or (documentation sym kind) :not-documented))
628 (maybe-push (property value)
629 (when value
630 (setf result (list* property value result)))))
631 (maybe-push
632 :variable (when (boundp symbol)
633 (doc 'variable)))
634 (maybe-push
635 :function (if (fboundp symbol)
636 (doc 'function)))
637 (maybe-push
638 :setf (let ((setf-function-name (ccl:setf-function-spec-name
639 `(setf ,symbol))))
640 (when (fboundp setf-function-name)
641 (doc 'function setf-function-name))))
642 (maybe-push
643 :type (when (ccl:type-specifier-p symbol)
644 (doc 'type)))
645 result)))
646
647 (defimplementation describe-definition (symbol namespace)
648 (ecase namespace
649 (:variable
650 (describe symbol))
651 ((:function :generic-function)
652 (describe (symbol-function symbol)))
653 (:setf
654 (describe (ccl:setf-function-spec-name `(setf ,symbol))))
655 (:class
656 (describe (find-class symbol)))
657 (:type
658 (describe (or (find-class symbol nil) symbol)))))
659
660 (defimplementation toggle-trace (spec)
661 "We currently ignore just about everything."
662 (ecase (car spec)
663 (setf
664 (ccl:trace-function spec))
665 ((:defgeneric)
666 (ccl:trace-function (second spec)))
667 ((:defmethod)
668 (destructuring-bind (name qualifiers specializers) (cdr spec)
669 (ccl:trace-function
670 (find-method (fdefinition name) qualifiers specializers)))))
671 t)
672
673 ;;; Macroexpansion
674
675 (defimplementation macroexpand-all (form)
676 (ccl:macroexpand-all form))
677
678 ;;;; Inspection
679
680 (defun comment-type-p (type)
681 (or (eq type :comment)
682 (and (consp type) (eq (car type) :comment))))
683
684 (defmethod emacs-inspect ((o t))
685 (let* ((inspector:*inspector-disassembly* t)
686 (i (inspector:make-inspector o))
687 (count (inspector:compute-line-count i)))
688 (loop for l from 0 below count append
689 (multiple-value-bind (value label type) (inspector:line-n i l)
690 (etypecase type
691 ((member nil :normal)
692 `(,(or label "") (:value ,value) (:newline)))
693 ((member :colon)
694 (label-value-line label value))
695 ((member :static)
696 (list (princ-to-string label) " " `(:value ,value) '(:newline)))
697 ((satisfies comment-type-p)
698 (list (princ-to-string label) '(:newline))))))))
699
700 (defmethod emacs-inspect :around ((o t))
701 (if (or (uvector-inspector-p o)
702 (not (ccl:uvectorp o)))
703 (call-next-method)
704 (let ((value (call-next-method)))
705 (cond ((listp value)
706 (append value
707 `((:newline)
708 (:value ,(make-instance 'uvector-inspector :object o)
709 "Underlying UVECTOR"))))
710 (t value)))))
711
712 (defclass uvector-inspector ()
713 ((object :initarg :object)))
714
715 (defgeneric uvector-inspector-p (object)
716 (:method ((object t)) nil)
717 (:method ((object uvector-inspector)) t))
718
719 (defmethod emacs-inspect ((uv uvector-inspector))
720 (with-slots (object) uv
721 (loop for i below (ccl:uvsize object) append
722 (label-value-line (princ-to-string i) (ccl:uvref object i)))))
723
724 ;;; Multiprocessing
725
726 (defvar *known-processes*
727 (make-hash-table :size 20 :weak :key :test #'eq)
728 "A map from threads to mailboxes.")
729
730 (defvar *known-processes-lock* (ccl:make-lock "*known-processes-lock*"))
731
732 (defstruct (mailbox (:conc-name mailbox.))
733 (mutex (ccl:make-lock "thread mailbox"))
734 (semaphore (ccl:make-semaphore))
735 (queue '() :type list))
736
737 (defimplementation spawn (fun &key name)
738 (ccl:process-run-function
739 (or name "Anonymous (Swank)")
740 fun))
741
742 (defimplementation thread-id (thread)
743 (ccl:process-serial-number thread))
744
745 (defimplementation find-thread (id)
746 (find id (ccl:all-processes) :key #'ccl:process-serial-number))
747
748 (defimplementation thread-name (thread)
749 (ccl:process-name thread))
750
751 (defimplementation thread-status (thread)
752 (format nil "~A" (ccl:process-whostate thread)))
753
754 (defimplementation thread-attributes (thread)
755 (list :priority (ccl:process-priority thread)))
756
757 (defimplementation make-lock (&key name)
758 (ccl:make-lock name))
759
760 (defimplementation call-with-lock-held (lock function)
761 (ccl:with-lock-grabbed (lock)
762 (funcall function)))
763
764 (defimplementation current-thread ()
765 ccl:*current-process*)
766
767 (defimplementation all-threads ()
768 (ccl:all-processes))
769
770 (defimplementation kill-thread (thread)
771 (ccl:process-kill thread))
772
773 (defimplementation thread-alive-p (thread)
774 (not (ccl:process-exhausted-p thread)))
775
776 (defimplementation interrupt-thread (thread function)
777 (ccl:process-interrupt
778 thread
779 (lambda ()
780 (let ((ccl:*top-error-frame* (ccl::%current-exception-frame)))
781 (funcall function)))))
782
783 (defun mailbox (thread)
784 (ccl:with-lock-grabbed (*known-processes-lock*)
785 (or (gethash thread *known-processes*)
786 (setf (gethash thread *known-processes*) (make-mailbox)))))
787
788 (defimplementation send (thread message)
789 (assert message)
790 (let* ((mbox (mailbox thread))
791 (mutex (mailbox.mutex mbox)))
792 (ccl:with-lock-grabbed (mutex)
793 (setf (mailbox.queue mbox)
794 (nconc (mailbox.queue mbox) (list message)))
795 (ccl:signal-semaphore (mailbox.semaphore mbox)))))
796
797 (defimplementation receive-if (test &optional timeout)
798 (let* ((mbox (mailbox ccl:*current-process*))
799 (mutex (mailbox.mutex mbox)))
800 (assert (or (not timeout) (eq timeout t)))
801 (loop
802 (check-slime-interrupts)
803 (ccl:with-lock-grabbed (mutex)
804 (let* ((q (mailbox.queue mbox))
805 (tail (member-if test q)))
806 (when tail
807 (setf (mailbox.queue mbox)
808 (nconc (ldiff q tail) (cdr tail)))
809 (return (car tail)))))
810 (when (eq timeout t) (return (values nil t)))
811 (ccl:timed-wait-on-semaphore (mailbox.semaphore mbox) 1))))
812
813 (defimplementation set-default-initial-binding (var form)
814 (eval `(ccl::def-standard-initial-binding ,var ,form)))
815
816 (defimplementation quit-lisp ()
817 (ccl:quit))
818
819 ;;; Weak datastructures
820
821 (defimplementation make-weak-key-hash-table (&rest args)
822 (apply #'make-hash-table :weak :key args))
823
824 (defimplementation make-weak-value-hash-table (&rest args)
825 (apply #'make-hash-table :weak :value args))
826
827 (defimplementation hash-table-weakness (hashtable)
828 (ccl:hash-table-weak-p hashtable))

  ViewVC Help
Powered by ViewVC 1.1.5