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

Contents of /slime/swank-ccl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5