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

Contents of /slime/swank-ccl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5