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

Contents of /slime/swank-ccl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5