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

Contents of /slime/swank-ccl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13 - (hide annotations)
Sun Jan 3 15:58:29 2010 UTC (4 years, 3 months ago) by sboukarev
Branch: MAIN
Changes since 1.12: +6 -1 lines
* contrib/slime-repl.el (sldb-insert-frame-call-to-repl): New function
for inserting a call to a frame into the REPL. Bound to C-y in SLDB.

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

  ViewVC Help
Powered by ViewVC 1.1.5