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

Contents of /slime/swank-ccl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (show annotations)
Wed Sep 23 11:19:55 2009 UTC (4 years, 6 months ago) by heller
Branch: MAIN
Changes since 1.5: +11 -7 lines
* swank-ccl.lisp (find-definitions): For fbound symbols also
consider source-notes in the function object.  Useful if
the function slot was set with (setf (symbol-function ..))
and not by defun.
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 (compiler-warning-short-message condition)
204 :source-context nil
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 (defun map-backtrace (function &optional
388 (start-frame-number 0)
389 (end-frame-number most-positive-fixnum))
390 "Call FUNCTION passing information about each stack frame
391 from frames START-FRAME-NUMBER to END-FRAME-NUMBER."
392 (ccl:map-call-frames function
393 :origin ccl:*top-error-frame*
394 :start-frame-number start-frame-number
395 :count (- end-frame-number start-frame-number)
396 :test (and (not t) ;(not (symbol-value (swank-sym *sldb-show-internal-frames*)))
397 'interesting-frame-p)))
398
399 ;; Exceptions
400 (defvar *interesting-internal-frames* ())
401
402 (defun interesting-frame-p (p context)
403 ;; A frame is interesting if it has at least one external symbol in its name.
404 (labels ((internal (obj)
405 ;; For a symbol, return true if the symbol is internal, i.e. not
406 ;; declared to be external. For a cons or list, everything
407 ;; must be internal. For a method, the name must be internal.
408 ;; Nothing else is internal.
409 (typecase obj
410 (cons (and (internal (car obj)) (internal (cdr obj))))
411 (symbol (and (eq (symbol-package obj) (find-package :ccl))
412 (eq :internal (nth-value 1 (find-symbol (symbol-name obj) :ccl)))
413 (not (member obj *interesting-internal-frames*))))
414 (method (internal (ccl:method-name obj)))
415 (t nil))))
416 (let* ((lfun (ccl:frame-function p context))
417 (internal-frame-p (internal (ccl:function-name lfun))))
418 #+debug (format t "~S is ~@[not ~]internal~%"
419 (ccl:function-name lfun)
420 (not internal-frame-p))
421 (not internal-frame-p))))
422
423
424 (defimplementation compute-backtrace (start-frame-number end-frame-number)
425 (let (result)
426 (map-backtrace (lambda (p context)
427 (push (list :frame p context) result))
428 start-frame-number end-frame-number)
429 (nreverse result)))
430
431 (defimplementation print-frame (frame stream)
432 (assert (eq (first frame) :frame))
433 (destructuring-bind (p context) (rest frame)
434 (let ((lfun (ccl:frame-function p context)))
435 (format stream "(~S" (or (ccl:function-name lfun) lfun))
436 (let* ((unavailable (cons nil nil))
437 (args (ccl:frame-supplied-arguments p context :unknown-marker unavailable)))
438 (declare (dynamic-extent unavailable))
439 (if (eq args unavailable)
440 (format stream " #<Unknown Arguments>")
441 (loop for arg in args
442 do (if (eq arg unavailable)
443 (format stream " #<Unavailable>")
444 (format stream " ~s" arg)))))
445 (format stream ")"))))
446
447 (defun call/frame (frame-number if-found)
448 (map-backtrace
449 (lambda (p context)
450 (return-from call/frame
451 (funcall if-found p context)))
452 frame-number))
453
454 (defmacro with-frame ((p context) frame-number &body body)
455 `(call/frame ,frame-number (lambda (,p ,context) . ,body)))
456
457 (defimplementation frame-var-value (frame var)
458 (with-frame (p context) frame
459 (cdr (nth var (ccl:frame-named-variables p context)))))
460
461 (defimplementation frame-locals (index)
462 (with-frame (p context) index
463 (loop for (name . value) in (ccl:frame-named-variables p context)
464 collect (list :name name :value value :id 0))))
465
466 (defimplementation frame-source-location (index)
467 (with-frame (p context) index
468 (multiple-value-bind (lfun pc) (ccl:frame-function p context)
469 (if pc
470 (pc-source-location lfun pc)
471 (function-source-location lfun)))))
472
473 (defimplementation eval-in-frame (form index)
474 (with-frame (p context) index
475 (let ((vars (ccl:frame-named-variables p context)))
476 (eval `(let ,(loop for (var . val) in vars collect `(,var ',val))
477 (declare (ignorable ,@(mapcar #'car vars)))
478 ,form)))))
479
480 (defimplementation return-from-frame (index form)
481 (let ((values (multiple-value-list (eval-in-frame form index))))
482 (with-frame (p context) index
483 (declare (ignore context))
484 (ccl:apply-in-frame p #'values values))))
485
486 (defimplementation restart-frame (index)
487 (with-frame (p context) index
488 (ccl:apply-in-frame p
489 (ccl:frame-function p context)
490 (ccl:frame-supplied-arguments p context))))
491
492 (defimplementation disassemble-frame (the-frame-number)
493 (with-frame (p context) the-frame-number
494 (multiple-value-bind (lfun pc) (ccl:frame-function p context)
495 (format t "LFUN: ~a~%PC: ~a FP: #x~x CONTEXT: ~a~%" lfun pc p context)
496 (disassemble lfun))))
497
498
499 ;; CCL commit r11373 | gz | 2008-11-16 16:35:28 +0100 (Sun, 16 Nov 2008)
500 ;; contains some interesting details:
501 ;;
502 ;; Source location are recorded in CCL:SOURCE-NOTE's, which are objects
503 ;; with accessors CCL:SOURCE-NOTE-FILENAME, CCL:SOURCE-NOTE-START-POS,
504 ;; CCL:SOURCE-NOTE-END-POS and CCL:SOURCE-NOTE-TEXT. The start and end
505 ;; positions are file positions (not character positions). The text will
506 ;; be NIL unless text recording was on at read-time. If the original
507 ;; file is still available, you can force missing source text to be read
508 ;; from the file at runtime via CCL:ENSURE-SOURCE-NOTE-TEXT.
509 ;;
510 ;; Source-note's are associated with definitions (via record-source-file)
511 ;; and also stored in function objects (including anonymous and nested
512 ;; functions). The former can be retrieved via
513 ;; CCL:FIND-DEFINITION-SOURCES, the latter via CCL:FUNCTION-SOURCE-NOTE.
514 ;;
515 ;; The recording behavior is controlled by the new variable
516 ;; CCL:*SAVE-SOURCE-LOCATIONS*:
517 ;;
518 ;; If NIL, don't store source-notes in function objects, and store only
519 ;; the filename for definitions (the latter only if
520 ;; *record-source-file* is true).
521 ;;
522 ;; If T, store source-notes, including a copy of the original source
523 ;; text, for function objects and definitions (the latter only if
524 ;; *record-source-file* is true).
525 ;;
526 ;; If :NO-TEXT, store source-notes, but without saved text, for
527 ;; function objects and defintions (the latter only if
528 ;; *record-source-file* is true). This is the default.
529 ;;
530 ;; PC to source mapping is controlled by the new variable
531 ;; CCL:*RECORD-PC-MAPPING*. If true (the default), functions store a
532 ;; compressed table mapping pc offsets to corresponding source locations.
533 ;; This can be retrieved by (CCL:FIND-SOURCE-NOTE-AT-PC function pc)
534 ;; which returns a source-note for the source at offset pc in the
535 ;; function.
536 ;;
537 ;; Currently the only thing that makes use of any of this is the
538 ;; disassembler. ILISP and current version of Slime still use
539 ;; backward-compatible functions that deal with filenames only. The plan
540 ;; is to make Slime, and our IDE, use this eventually.
541
542 (defun function-source-location (function)
543 (source-note-to-source-location
544 (ccl:function-source-note function)
545 (lambda ()
546 (format nil "Function has no source note: ~A" function))
547 (ccl:function-name function)))
548
549 (defun pc-source-location (function pc)
550 (source-note-to-source-location
551 (or (ccl:find-source-note-at-pc function pc)
552 (ccl:function-source-note function))
553 (lambda ()
554 (format nil "No source note at PC: ~a[~d]" function pc))
555 (ccl:function-name function)))
556
557 (defun source-note-to-source-location (source if-nil-thunk &optional name)
558 (labels ((filename-to-buffer (filename)
559 (cond ((gethash filename *temp-file-map*)
560 (list :buffer (gethash filename *temp-file-map*)))
561 ((probe-file filename)
562 (list :file (ccl:native-translated-namestring (truename filename))))
563 (t (error "File ~s doesn't exist" filename)))))
564 (handler-case
565 (cond ((ccl:source-note-p source)
566 (let* ((full-text (ccl:source-note-text source))
567 (file-name (ccl:source-note-filename source))
568 (start-pos (ccl:source-note-start-pos source)))
569 (make-location
570 (when file-name (filename-to-buffer (pathname file-name)))
571 (when start-pos (list :position (1+ start-pos)))
572 (when full-text (list :snippet (subseq full-text 0 (min 40 (length full-text))))))))
573 ((and source name)
574 (make-location
575 (filename-to-buffer source)
576 (list :function-name (let ((*package* (find-package :swank-io-package))) ;; should be buffer package.
577 (with-standard-io-syntax
578 (princ-to-string (if (functionp name)
579 (ccl:function-name name)
580 name)))))))
581 (t `(:error ,(funcall if-nil-thunk))))
582 (error (c) `(:error ,(princ-to-string c))))))
583
584 (defimplementation find-definitions (name)
585 (let ((defs (or (ccl:find-definition-sources name)
586 (and (symbolp name)
587 (fboundp name)
588 (ccl:find-definition-sources (symbol-function name))))))
589 (loop for ((type . name) . sources) in defs
590 collect (list (definition-name type name)
591 (source-note-to-source-location
592 (find-if-not #'null sources)
593 (lambda () "No source-note available")
594 name)))))
595
596 (defimplementation find-source-location (obj)
597 (let* ((defs (ccl:find-definition-sources obj))
598 (best-def (or (find (ccl:name-of obj) defs :key #'cdar :test #'equal)
599 (car defs)))
600 (note (find-if-not #'null (cdr best-def))))
601 (when note
602 (source-note-to-source-location
603 note
604 (lambda () "No source note available")))))
605
606 (defun definition-name (type object)
607 (case (ccl:definition-type-name type)
608 (method (ccl:name-of object))
609 (t (list (ccl:definition-type-name type) (ccl:name-of object)))))
610
611 ;;; Utilities
612
613 (defimplementation describe-symbol-for-emacs (symbol)
614 (let ((result '()))
615 (flet ((doc (kind &optional (sym symbol))
616 (or (documentation sym kind) :not-documented))
617 (maybe-push (property value)
618 (when value
619 (setf result (list* property value result)))))
620 (maybe-push
621 :variable (when (boundp symbol)
622 (doc 'variable)))
623 (maybe-push
624 :function (if (fboundp symbol)
625 (doc 'function)))
626 (maybe-push
627 :setf (let ((setf-function-name (ccl:setf-function-spec-name
628 `(setf ,symbol))))
629 (when (fboundp setf-function-name)
630 (doc 'function setf-function-name))))
631 (maybe-push
632 :type (when (ccl:type-specifier-p symbol)
633 (doc 'type)))
634 result)))
635
636 (defimplementation describe-definition (symbol namespace)
637 (ecase namespace
638 (:variable
639 (describe symbol))
640 ((:function :generic-function)
641 (describe (symbol-function symbol)))
642 (:setf
643 (describe (ccl:setf-function-spec-name `(setf ,symbol))))
644 (:class
645 (describe (find-class symbol)))
646 (:type
647 (describe (or (find-class symbol nil) symbol)))))
648
649 (defimplementation toggle-trace (spec)
650 "We currently ignore just about everything."
651 (ecase (car spec)
652 (setf
653 (ccl:trace-function spec))
654 ((:defgeneric)
655 (ccl:trace-function (second spec)))
656 ((:defmethod)
657 (destructuring-bind (name qualifiers specializers) (cdr spec)
658 (ccl:trace-function
659 (find-method (fdefinition name) qualifiers specializers)))))
660 t)
661
662 ;;; Macroexpansion
663
664 (defimplementation macroexpand-all (form)
665 (ccl:macroexpand-all form))
666
667 ;;;; Inspection
668
669 (defun comment-type-p (type)
670 (or (eq type :comment)
671 (and (consp type) (eq (car type) :comment))))
672
673 (defmethod emacs-inspect ((o t))
674 (let* ((inspector:*inspector-disassembly* t)
675 (i (inspector:make-inspector o))
676 (count (inspector:compute-line-count i)))
677 (loop for l from 0 below count append
678 (multiple-value-bind (value label type) (inspector:line-n i l)
679 (etypecase type
680 ((member nil :normal)
681 `(,(or label "") (:value ,value) (:newline)))
682 ((member :colon)
683 (label-value-line label value))
684 ((member :static)
685 (list (princ-to-string label) " " `(:value ,value) '(:newline)))
686 ((satisfies comment-type-p)
687 (list (princ-to-string label) '(:newline))))))))
688
689 (defmethod emacs-inspect :around ((o t))
690 (if (or (uvector-inspector-p o)
691 (not (ccl:uvectorp o)))
692 (call-next-method)
693 (let ((value (call-next-method)))
694 (cond ((listp value)
695 (append value
696 `((:newline)
697 (:value ,(make-instance 'uvector-inspector :object o)
698 "Underlying UVECTOR"))))
699 (t value)))))
700
701 (defclass uvector-inspector ()
702 ((object :initarg :object)))
703
704 (defgeneric uvector-inspector-p (object)
705 (:method ((object t)) nil)
706 (:method ((object uvector-inspector)) t))
707
708 (defmethod emacs-inspect ((uv uvector-inspector))
709 (with-slots (object) uv
710 (loop for i below (ccl:uvsize object) append
711 (label-value-line (princ-to-string i) (ccl:uvref object i)))))
712
713 ;;; Multiprocessing
714
715 (defvar *known-processes*
716 (make-hash-table :size 20 :weak :key :test #'eq)
717 "A map from threads to mailboxes.")
718
719 (defvar *known-processes-lock* (ccl:make-lock "*known-processes-lock*"))
720
721 (defstruct (mailbox (:conc-name mailbox.))
722 (mutex (ccl:make-lock "thread mailbox"))
723 (semaphore (ccl:make-semaphore))
724 (queue '() :type list))
725
726 (defimplementation spawn (fun &key name)
727 (ccl:process-run-function
728 (or name "Anonymous (Swank)")
729 fun))
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))
761
762 (defimplementation thread-alive-p (thread)
763 (not (ccl:process-exhausted-p thread)))
764
765 (defimplementation interrupt-thread (thread function)
766 (ccl:process-interrupt
767 thread
768 (lambda ()
769 (let ((ccl:*top-error-frame* (ccl::%current-exception-frame)))
770 (funcall function)))))
771
772 (defun mailbox (thread)
773 (ccl:with-lock-grabbed (*known-processes-lock*)
774 (or (gethash thread *known-processes*)
775 (setf (gethash thread *known-processes*) (make-mailbox)))))
776
777 (defimplementation send (thread message)
778 (assert message)
779 (let* ((mbox (mailbox thread))
780 (mutex (mailbox.mutex mbox)))
781 (ccl:with-lock-grabbed (mutex)
782 (setf (mailbox.queue mbox)
783 (nconc (mailbox.queue mbox) (list message)))
784 (ccl:signal-semaphore (mailbox.semaphore mbox)))))
785
786 (defimplementation receive-if (test &optional timeout)
787 (let* ((mbox (mailbox ccl:*current-process*))
788 (mutex (mailbox.mutex mbox)))
789 (assert (or (not timeout) (eq timeout t)))
790 (loop
791 (check-slime-interrupts)
792 (ccl:with-lock-grabbed (mutex)
793 (let* ((q (mailbox.queue mbox))
794 (tail (member-if test q)))
795 (when tail
796 (setf (mailbox.queue mbox)
797 (nconc (ldiff q tail) (cdr tail)))
798 (return (car tail)))))
799 (when (eq timeout t) (return (values nil t)))
800 (ccl:timed-wait-on-semaphore (mailbox.semaphore mbox) 1))))
801
802 (defimplementation set-default-initial-binding (var form)
803 (eval `(ccl::def-standard-initial-binding ,var ,form)))
804
805 (defimplementation quit-lisp ()
806 (ccl:quit))
807
808 ;;; Weak datastructures
809
810 (defimplementation make-weak-key-hash-table (&rest args)
811 (apply #'make-hash-table :weak :key args))
812
813 (defimplementation make-weak-value-hash-table (&rest args)
814 (apply #'make-hash-table :weak :value args))
815
816 (defimplementation hash-table-weakness (hashtable)
817 (ccl:hash-table-weak-p hashtable))

  ViewVC Help
Powered by ViewVC 1.1.5